1889 lines
58 KiB
Perl
Executable File
1889 lines
58 KiB
Perl
Executable File
#!/usr/bin/perl
|
|
# -------- description + version history -------- #FOLD00
|
|
|
|
=head1 PerlForth
|
|
an incremental compiler and interactive interpreter, based on a
|
|
virtual machine, executing indirect threaded code.
|
|
|
|
=cut
|
|
|
|
my $version = 27;
|
|
# to do: improved file interface. can only read source files to compile from now.
|
|
# time of last change:
|
|
|
|
# 20110428,ls 0.27 arithmetic on addresses may result in negative mem array indici. changed some memory primitives to unsign addresses
|
|
# 20110427,ls problem with 64 bit. forcing to 32 bit for now.
|
|
# 20110420,ls 0.26 string packing and unpacking using W type strings.
|
|
# 20091001,ls 0.25 initialising catchframe in empty avoids undefined error handler when quitting in site-forth.4th
|
|
# 20090930,ls 0.24 loading /usr/local/share/perlforth/site-forth.4th at start
|
|
# 20090106,ls 0.23 fixes for 64bit Perl versions
|
|
# 20090106,ls 0.22 can compile source from included file.
|
|
# 20090103,ls 0.21 vocabularies.
|
|
# 20090101,ls 0.20 prepared for vocabularies.
|
|
# 20081228,ls 0.19 radix prefixes
|
|
# 20081228,ls 0.18 catch, throw, top level error handler, fixed bug in hash which rendered does> defective
|
|
# 20081228,ls 0.17 experimentally connected Perl exception handler to interpreter errors
|
|
# 20081223,ls 0.16 does>, keymap lister, linked vars, defers, constants, arrays.
|
|
# 20081223,ls 0.15 hilevelized/deperled many words. key is now deferred. cleanup. stuff added.
|
|
# 20081221,ls 0.14 simulated disk loaded during boot, extending interpreter.
|
|
# better compile-time word defining macros.
|
|
# branching version which moves definitions to simulated disk.
|
|
# 20081221,ls 0.13 simulated disk for testing compiling from file.
|
|
# 20081221,ls 0.12 some string support: ." s" ," /string move$
|
|
# 20081220,ls 0.11 added move fill for next leave ?leave i j do ?do loop
|
|
# 20081217,ls 0.10 numbers, if else then begin while repeat until again.
|
|
# 20081217,ls 0.09 added [ ], create, variable, : ; colon definitions work.
|
|
# 20081217,ls 0.08 input line is parsed now. "real" interpreter connected,
|
|
# but compilation and numbers are stubs.
|
|
# 20081217,ls 0.07 bit logic, comparison, keymap customizer, hide/reveal, skip/scan
|
|
# 20081215,ls 0.06 debugging and cleanup
|
|
# 20081215,ls 0.05 rudimentary command execution loop
|
|
# 20081214,ls 0.04 rudimentary buffered line input, more primitives.
|
|
# 20081213,ls 0.03 more run time words, primitives, flow control
|
|
# 20081211,ls 0.02 added run time words, constants, minimal flow control
|
|
# 20081210,ls 0.01 ITC inner interpreter executes lo- and hilevel
|
|
|
|
|
|
use strict;
|
|
use warnings;
|
|
|
|
use Term::ReadKey;
|
|
#use Term::ANSIColor;
|
|
|
|
# -------- configuration items -------- #FOLD00
|
|
|
|
my $tibsize = 256; # size of terminal input buffer
|
|
my $cell;
|
|
|
|
# override. uses perl compilation width if undefined.
|
|
# $cell = 0; # bits per cell determined by size perl has been compiled for
|
|
# $cell = 0xffff; # 16 bit override
|
|
$cell = 0xffffffff; # 32 bit override
|
|
# $cell = 0xffffffffffffffff; # 64 bit override
|
|
# 2011apr27,ls problem with 64 bit. forcing to 32 bit for now.
|
|
|
|
|
|
# -------- simulated sources disk -------- #FOLD00
|
|
|
|
|
|
# simulated source disk, contents are loaded and compiled during boot
|
|
my @disk =
|
|
(
|
|
"forth only",
|
|
"forth definitions",
|
|
'#10 base !',
|
|
|
|
': binary 2 base ! ;', # ( -- )
|
|
': octal 8 base ! ;', # ( -- )
|
|
': decimal 10 base ! ;', # ( -- )
|
|
': hex 16 base ! ;', # ( -- )
|
|
|
|
|
|
": align ; immediate", # ( -- )
|
|
": aligned ; immediate", # ( a1 -- a2 )
|
|
": pad here 256 + ;", # ( -- a )
|
|
|
|
": latest last @ ;", # ( -- a )
|
|
": recurse latest , ; immediate", # ( -- )
|
|
"also hidden",
|
|
": compile r> skim , >r ;", # ( -- )
|
|
": postpone ' , ; immediate", # ( -- )
|
|
": literal ?comp (lit) (lit) , , ; immediate", # ( x -- ) ( -- x )
|
|
": ['] ' postpone literal ; immediate", # ( -- ) ( -- a )
|
|
"previous",
|
|
# --- chars and strings ---
|
|
': char bl parse drop c@ ;', # ( -- c )
|
|
': [char] char postpone literal ; immediate', # ( -- ) ( -- c )
|
|
': ctrl char $1F and ;', # ( -- c )
|
|
': [ctrl] ctrl postpone literal ; immediate', # ( -- ) ( -- c )
|
|
|
|
': \ 0 parse 2drop ; immediate', # ( -- )
|
|
': // postpone \ ; immediate', # ( -- )
|
|
|
|
': s( [char] ) parse ;', # ( -- a n )
|
|
': ( s( 2drop ; immediate', # ( -- )
|
|
': .( s( type ;', # ( -- )
|
|
"also hidden",
|
|
': move$ 2dup c! 1+ swap move ;', # ( a1 n a2 -- )
|
|
': ,s here over 1+ allot move$ ;', # ( a n -- )
|
|
': ," [char] " parse ,s ;', # ( -- )
|
|
': s" ?comp [\'] (slit) , ," ; immediate', # ( -- ) ( -- a n )
|
|
': ." ?comp [\'] (.") , ," ; immediate', # ( -- ) ( -- )
|
|
|
|
|
|
# --- flow control ---
|
|
"definitions",
|
|
': resolve here - , ;', # ( a -- )
|
|
': <resolve here over - swap ! ;', # ( a -- )
|
|
": ?clause compile (0branch) ;", # ( -- )
|
|
": clause compile (branch) ;", # ( -- )
|
|
": mark here 0 , ;", # ( -- a )
|
|
"previous definitions",
|
|
|
|
"also hidden",
|
|
': if ?comp ?clause mark 1 ; immediate',
|
|
': else ?comp 1 structured clause mark swap <resolve 2 ; immediate',
|
|
': then ?comp dup 2 = + 1 structured <resolve ; immediate',
|
|
': endif postpone then ; immediate',
|
|
': begin ?comp here 3 ; immediate',
|
|
': while ?comp 3 structured ?clause mark 4 ; immediate',
|
|
': repeat ?comp 4 structured swap clause resolve <resolve ; immediate',
|
|
': until ?comp 3 structured ?clause resolve ; immediate',
|
|
': again ?comp 3 structured clause resolve ; immediate',
|
|
"definitions",
|
|
": docompiler create , , immediate",
|
|
" does> ?comp skim , @ >r",
|
|
" here innerloop exchange",
|
|
" mark r> ;",
|
|
": loopcompiler create , , immediate",
|
|
" does> ?comp skim >r @ structured r> , dup 1+ resolve <resolve innerloop ! ;",
|
|
"previous definitions",
|
|
|
|
"also hidden",
|
|
"5 ' (do) docompiler do",
|
|
"5 ' (?do) docompiler ?do",
|
|
"6 ' (for) docompiler for",
|
|
"5 ' (loop) loopcompiler loop",
|
|
"5 ' (+loop) loopcompiler +loop",
|
|
"6 ' (next) loopcompiler next",
|
|
|
|
": leave, ?comp innerloop @ ?dup 0= -26 and throw swap , , ;",
|
|
": leave ['] (leave) leave, ; immediate",
|
|
": ?leave ['] (?leave) leave, ; immediate",
|
|
": unloop ?comp innerloop @ 0= -26 and throw compile (unloop) ; immediate",
|
|
|
|
# ---
|
|
': tuck swap over ;', # ( x1 x2 -- x2 x1 x2 )
|
|
': pluck 2 pick ;', # ( x1 x2 x3 -- x1 x2 x3 x1 )
|
|
': max 2dup < if swap then drop ;', # ( x1 x2 -- x1|x2 )
|
|
': min 2dup > if swap then drop ;', # ( x1 x2 -- x1|x2 )
|
|
': -rot rot rot ;', # ( x1 x2 x3 -- x3 x1 x2 )
|
|
|
|
': (abort") if -2 dup r> count newerror throw then',
|
|
' r> count + >r ;',
|
|
': abort" ?comp compile (abort") ," ; immediate', # ( f -- )
|
|
|
|
': link here swap exchange , ;',
|
|
': unlink dup @ ?dup if @ over ! then drop ;',
|
|
|
|
# tricky: 'make new constants behave like "true" (which is a constant)'
|
|
# tricky: 'make new deferred words behave like "key" (which is a deferred word)'
|
|
# tricky: 'make new arrays behave like "keytable" (which is an array)'
|
|
# tricky: 'make new vocabularies behave like "forth" (which is a vocabulary)'
|
|
": constant constants link create , [ ' true @ ] literal use ;",
|
|
'1 constant cell',
|
|
": defer defers link create cell allot [ ' key @ ] literal use ;",
|
|
": array arrays link create dup , allot [ ' keytable @ ] literal use ;",
|
|
": vocabulary vocabularies link create 0 , 0 , [ ' forth @ ] literal use ;",
|
|
': variable variables link create cell allot ;',
|
|
": value constant ;", # values behave like constants. for now.
|
|
': vocs vocabularies begin @ ?dup while dup 1+ .name space repeat ;',
|
|
'previous',
|
|
|
|
': cell+ 1+ ; : char+ 1+ ;',
|
|
': cell- 1- ; : char- 1- ;',
|
|
': cells ; : chars ; ',
|
|
|
|
': range over + swap ;', # ( x1 n -- x2 x1 )
|
|
': erase 0 fill ;', # ( a n -- )
|
|
': blank bl fill ;', # ( a n -- )
|
|
': c, 255 and , ;', # ( c -- )
|
|
|
|
': within pluck < >r < r> or 0= ;', # ( n1 n2 n3 -- f )
|
|
': printable bl 127 within ;', # ( c -- f )
|
|
|
|
': emits swap dup 0> and', # ( u c -- )
|
|
' 0 ?do dup emit loop drop ;',
|
|
': spaces bl emits ;', # ( u -- )
|
|
|
|
': >body cell+ ; ', # ( a1 -- a2 )
|
|
': body> cell- ; ', # ( a1 -- a2 )
|
|
|
|
': word here >r parse r@ move$ r> ;', # ( c -- a )
|
|
|
|
': lines >r', # ( a -- )
|
|
' bl word count',
|
|
' fileopen',
|
|
' begin fileread',
|
|
' while r@ execute',
|
|
' repeat',
|
|
' fileclose rdrop ;',
|
|
|
|
": from fileopen", # ( a n -- )
|
|
" begin fileread",
|
|
" while evaluate",
|
|
" repeat fileclose ;",
|
|
|
|
': from" [char] " parse from ;', # ( -- )
|
|
|
|
# is and to identical yet but they will check to make sure the target is of proper type
|
|
# therefore no factoring in these words, as these are in transition.
|
|
"also hidden definitions",
|
|
": (was) r> dup cell+ >r @ >body @ ;",
|
|
": (is) r> dup cell+ >r @ >body ! ;",
|
|
": (to) r> dup cell+ >r @ >body ! ;",
|
|
"previous definitions",
|
|
|
|
"also hidden",
|
|
": was compiling if compile (was) exit then ' >body @ ; immediate",
|
|
": is compiling if compile (is) exit then ' >body ! ; immediate",
|
|
": to compiling if compile (to) exit then ' >body ! ; immediate",
|
|
"previous",
|
|
|
|
# --- obsolescent input parsing and vocabulary search. required by dpans94 ---
|
|
|
|
': find dup count hunt', # ( a1 -- a2 0 | a2 1 | a2 -1 )
|
|
' dup if', # 1: immediate. -1: non-immediate
|
|
' nip dup name>',
|
|
' swap ?imm invert 1 or',
|
|
' then ;',
|
|
|
|
# --- pictured number output conversion ---
|
|
': s>d dup 0< ;', # ( x -- d )
|
|
': <# swap >r pad tuck r> ;', # ( d -- a x a x )
|
|
|
|
': #> drop nip tuck - ;', # ( a x a x -- a x )
|
|
': hold rot 1-', # ( a x c -- a x )
|
|
' dup here < -17 and throw',
|
|
' -rot pluck c! ;',
|
|
': cipher dup 9 > if 7 + then [char] 0 + ;', # ( n -- c )
|
|
': # base @ u/mod swap cipher hold ;', # ( a x -- a x )
|
|
': #s begin # dup 0= until ;', # ( a x -- a x )
|
|
': sign pluck 0< if [char] - hold then ;', # ( x a x -- x a x )
|
|
': string <# #s sign #> ;', # ( n -- a n )
|
|
': (.) s>d >r abs r> string ;', # ( n1 -- a n2 )
|
|
': (u.) 0 string ;', # ( u -- a n )
|
|
': . (.) type space ;', # ( n -- )
|
|
': u. (u.) type space ;', # ( u -- )
|
|
': (.r) over - spaces type ;', # ( a n1 n2 -- )
|
|
': .r >r (.) r> (.r) ;', # ( n u -- )
|
|
': u.r >r (u.) r> (.r) ;', # ( u1 u2 -- )
|
|
|
|
': .b base exchange swap u. base ! ;', # ( n base -- )
|
|
': .% 2 .b ;', # ( n -- )
|
|
': .# 10 .b ;', # ( n -- )
|
|
': .$ 16 .b ;', # ( n -- )
|
|
': .s depth ?dup if', # ( -- )
|
|
' for i pick . next',
|
|
' else ." stack empty"',
|
|
' then ;',
|
|
': number ?number 0= -24 and throw ;', # ( a n1 -- n2 )
|
|
|
|
# --- string words
|
|
': /string over min tuck 2>r + 2r> - ;', # ( a n1 n2 -- )
|
|
': -trailing dup if dup for 1- 2dup + c@ bl <> ?leave next 1+ then ;',
|
|
# left/right boundary, centered type
|
|
': typer ( a n1 n2 -- ) over - 0 max spaces type ;',
|
|
': typel ( a n1 n2 -- ) over - 0 max >r type r> spaces ;',
|
|
': typec ( a n1 n2 -- ) over - 0 max dup 2/ dup spaces - >r type r> spaces ;',
|
|
|
|
# --- 'char, ^ctrlchar, >shellcommand input
|
|
"also hidden definitions",
|
|
': toshell 1 /string drop 0 parse + over -', # ( a n -- )
|
|
' compiling if compile (slit) ,s compile then shell ;',
|
|
": andchar nip swap 1+ c@ and compiling if postpone literal then ;", # ( a n -- c )
|
|
": tochar 255 andchar ;", # ( a n -- c )
|
|
": toctrl 31 andchar ;", # ( a n -- c )
|
|
': dispatchable s" \'^>" rot scan nip ;', # ( c -- u )
|
|
" create action ] toshell toctrl tochar [",
|
|
': dispatch action + @ execute ;', # ( a n1 n2 -- ? )
|
|
": prefixes over c@ dispatchable ?dup if 1- dispatch exit then",
|
|
#" 2dup analyze_input if process_input exit then",
|
|
" (notfound) ;",
|
|
"' prefixes is notfound", # ( a n -- ? )
|
|
|
|
': .? dup defined if . else drop ." undefined" then ;',
|
|
': .linknames',
|
|
' >r begin @ ?dup',
|
|
' while dup 1+',
|
|
' dup cr .name ." : "',
|
|
' >body @ r@ execute',
|
|
' repeat rdrop cr ;',
|
|
|
|
": .variables variables ['] .? .linknames ;",
|
|
": .constants constants ['] . .linknames ;",
|
|
": .arrays arrays ['] . .linknames ;",
|
|
": .defers defers ['] .name .linknames ;",
|
|
": .vocs vocabularies ['] . .linknames ;",
|
|
": user_interrupt -28 throw ;",
|
|
"previous definitions",
|
|
|
|
': shell: create ," does> count shell ;',
|
|
'shell: page clear',
|
|
'shell: ps ps auxf|pager',
|
|
'shell: sh bash',
|
|
|
|
': command: create does> drop source shell postpone \ ;',
|
|
'command: ls',
|
|
': cls page ;',
|
|
': commandline ." (ctrl-D to exit)" sh ." ok" cr ;',
|
|
': .keys -1 keytable @ 0 do',
|
|
' i keytable @',
|
|
' ?dup if',
|
|
" dup ['] nop <> if",
|
|
' cr ." ctrl-" i \'@ + emit',
|
|
' 3 spaces dup .name',
|
|
' then',
|
|
' drop',
|
|
' then',
|
|
' loop cr ;',
|
|
|
|
# "0 keytable -1 keytable @ ' nop fill",
|
|
"0 keytable bl ' nop fill",
|
|
": bindkey keytable ! ;",
|
|
|
|
"also hidden",
|
|
"' .arrays ^A bindkey",
|
|
"' .constants ^B bindkey",
|
|
"' user_interrupt ^C bindkey",
|
|
"' commandline ^D bindkey",
|
|
"' .defers ^E bindkey",
|
|
" 0 ^H bindkey",
|
|
" 0 ^I bindkey",
|
|
" 0 ^J bindkey",
|
|
"' .keys ^K bindkey",
|
|
"' page ^L bindkey",
|
|
"' order ^O bindkey",
|
|
"' bye ^Q bindkey",
|
|
"' .variables ^V bindkey",
|
|
"' words ^W bindkey",
|
|
"' .vocs ^X bindkey",
|
|
|
|
': fkey',
|
|
' begin (key)',
|
|
' dup bl < 0= unless',
|
|
' dup keytable @',
|
|
' ?dup while',
|
|
' execute drop',
|
|
' repeat ;',
|
|
|
|
': accept >r 0', # ( a n1 -- n2 )
|
|
' begin dup r@ <>',
|
|
' while fkey dup 10 =',
|
|
' if r> 2drop dup >r',
|
|
' else decode',
|
|
' then',
|
|
' repeat swap r> 2drop ;',
|
|
|
|
': query tib dup tibsize accept dup #tib ! pushsource space ;',
|
|
"definitions",
|
|
": (quit) empty postpone [ begin query interpret prompt again ;",
|
|
"' (quit) is quit",
|
|
': (prompt) compiling 0= if ." ok" depth 0 ?do \'. emit loop then cr ;',
|
|
"' (prompt) is prompt",
|
|
"previous definitions",
|
|
|
|
#": recent context @ >body @ ;",
|
|
": :noname ?exec here [ latest @ ] literal , ] ; immediate",
|
|
|
|
': up s" ./up" shell ;',
|
|
': doc s" ./doc" shell ;',
|
|
|
|
#": bogo 1000000 0 do loop bye ; bogo",
|
|
#' from hexdump.4th',
|
|
|
|
# -- time
|
|
": time ( -- secs ) epoch 86400 mod ;",
|
|
": ##: ( u1 -- u2 ) base @ >r decimal # 6 base ! # ': hold r> base ! ;",
|
|
": .now ( -- ) time s>d <# ##: ##: #s #> type ;",
|
|
": now ( -- s m h ) time 60 /mod 60 /mod ;",
|
|
|
|
# load site-forth.4th at start
|
|
' :noname ( -- ) s" /usr/local/share/perlforth/site-forth.4th" from ; catch drop',
|
|
# ' \ dup -38 <> and throw',
|
|
|
|
'.( Threaded Code Interpreter in Perl, version )',
|
|
" version s>d <# # # '. hold #s #> type",
|
|
" '. emit here . cr space",
|
|
|
|
|
|
);
|
|
|
|
|
|
# -------- virtual machine data --------
|
|
# VM memory
|
|
my @m; # main memory
|
|
my @s; # user stack
|
|
my @r; # return stack
|
|
|
|
# global VM registers
|
|
my $sp; # user stack pointer
|
|
my $rp; # return stack pointer
|
|
my $w; # word pointer
|
|
my $ip; # instruction pointer
|
|
|
|
# global interpreter/compiler variables
|
|
my $dp = 0; # pointer to free VM mem
|
|
my $wc = 0; # word count, analog the name field address
|
|
my @header; # word headers
|
|
my @body; # pointers to word code fields
|
|
my @voclink; # pointer to index of next word of same vocabulary
|
|
my @precedence; # reveal/precedence flags per word
|
|
|
|
my $parsebuf; # pointer to current source buffer
|
|
my $parsebuflen; # size of current source buffer
|
|
my @sourcestack; # holds nested source buffer
|
|
my %does; # helper hash for create .. does> simplification
|
|
my $catchframe = 0; # pointer to prev catch/throw context (or 0)
|
|
|
|
|
|
|
|
my $maxu = (-1|0); # determine cell size in bits
|
|
$maxu = $cell if ($cell); # or use override
|
|
my $wrap = $maxu+1; # modulo for trimming results to fit into cell
|
|
my $msb = 1; # value with only the most significant bit set
|
|
my $bits = 1;
|
|
for (;$msb<$wrap/2;$msb+=$msb) {$bits++}
|
|
#print "$msb, $bits";
|
|
|
|
my $revealbit = 1;
|
|
my $precedencebit = 2;
|
|
|
|
# variables residing in interpreter virtual memory space.
|
|
|
|
sub comma {
|
|
$m[$dp] = shift(@_);
|
|
return $dp++;
|
|
}
|
|
|
|
|
|
my @vocstack;
|
|
my $xlaststore = comma 0;
|
|
my $xcurrentstore = comma 0;
|
|
my $xcontextstore = comma 0;
|
|
|
|
|
|
# -------- virtual machine --------
|
|
|
|
#$meow = $model ? sub { 'purr' } : sub { q/=^_^=/ }; $meow->();
|
|
|
|
sub nest { $r[++$rp] = $ip; $ip = $w+1; }
|
|
sub unnest { $ip = $r[$rp--]; }
|
|
my $unnest = $dp;
|
|
$m[$dp++] = \&unnest;
|
|
|
|
sub doconst { $s[++$sp] = $m[$w+1]; }
|
|
sub dovar { $s[++$sp] = $w+1; }
|
|
sub dodefer { $w = $m[$w+1]; $m[$w](); }
|
|
sub dovoc { $m[$xcontextstore] = $w; }
|
|
|
|
|
|
# -------- vocabularies --------
|
|
|
|
sub reveal { $precedence[$wc-1] |= $revealbit; }
|
|
sub immediate { $precedence[$wc-1] |= $precedencebit; }
|
|
sub hide { $precedence[$wc-1] &= ~$revealbit; }
|
|
|
|
sub header {
|
|
$header[$wc] = shift(@_);
|
|
$body[$wc] = $dp;
|
|
$precedence[$wc] = 0;
|
|
$voclink[$wc] = $m[$m[$xcurrentstore]+2];
|
|
$m[$xlaststore] = $dp;
|
|
$m[$m[$xcurrentstore]+1] = $dp;
|
|
$m[$m[$xcurrentstore]+2] = $wc;
|
|
$wc++;
|
|
return $dp;
|
|
}
|
|
|
|
|
|
sub xlink {
|
|
my $anchor = (shift(@_))+1;
|
|
($m[$anchor], $m[$dp]) = ($dp, $m[$anchor]);
|
|
$dp++;
|
|
}
|
|
|
|
sub allot { $dp += shift(@_); }
|
|
|
|
my $xvocabularies = comma \&dovar; comma 0; # a hand-built variable, needed early.(for linking
|
|
# vocabularies needed to contain the link anchors
|
|
# of variables, constant, vocabularies...)
|
|
sub vocabulary {
|
|
xlink $xvocabularies;
|
|
my $addr = comma \&dovoc; comma 0; comma 0; # last cfa, last wc.
|
|
return $addr;
|
|
}
|
|
|
|
my $xonlyvoc = vocabulary; sub only { $m[$xcontextstore] = $xonlyvoc; }
|
|
my $xforth = vocabulary; sub forth { $m[$xcontextstore] = $xforth; }
|
|
my $xhidden = vocabulary; sub hidden { $m[$xcontextstore] = $xhidden; }
|
|
|
|
sub definitions { $m[$xcurrentstore] = $m[$xcontextstore] }
|
|
|
|
hidden; definitions;
|
|
header ""; # must be header 0 (0 represents end
|
|
# of chain, common for all vocabularies)
|
|
|
|
# to do:
|
|
# hand-craft a link anchor, used as link anchor for list of link anchors here.
|
|
# link "vocabularies" link anchor to this link anchor. later, create a header,
|
|
# link "anchors" to itself. moala - mother of all link anchors.
|
|
|
|
header "vocabularies"; reveal; # header for vocabularies link anchor.
|
|
$body[$wc-1] = $xvocabularies;
|
|
|
|
only; definitions;
|
|
header "forth"; reveal;
|
|
$body[$wc-1] = $xforth;
|
|
|
|
forth; definitions;
|
|
header "only"; reveal;
|
|
$body[$wc-1] = $xonlyvoc;
|
|
|
|
header "hidden"; reveal;
|
|
$body[$wc-1] = $xhidden;
|
|
|
|
|
|
# -------- macros: defining words -------- #FOLD00
|
|
|
|
|
|
sub compile {
|
|
my $addr = $dp;
|
|
foreach my $i (0..$#_) {
|
|
comma $_[$i];
|
|
}
|
|
return $addr;
|
|
}
|
|
|
|
sub colon {
|
|
header shift(@_);
|
|
return compile \&nest;
|
|
}
|
|
|
|
sub semicolon {
|
|
compile $unnest;
|
|
reveal;
|
|
}
|
|
|
|
sub unnamedprimitive {
|
|
return compile shift(@_);
|
|
}
|
|
|
|
sub primitive {
|
|
header shift(@_);
|
|
reveal;
|
|
return compile shift(@_);
|
|
}
|
|
|
|
sub create {
|
|
header shift(@_);
|
|
reveal;
|
|
return compile \&dovar;
|
|
}
|
|
|
|
sub xnop { }
|
|
my $xnop = primitive "nop", \&xnop;
|
|
|
|
|
|
hidden; definitions;
|
|
my $xconstants = create "constants"; comma 0;
|
|
sub constant {
|
|
xlink $xconstants;
|
|
header shift(@_);
|
|
reveal;
|
|
return compile \&doconst, shift(@_);
|
|
}
|
|
|
|
my $xvariables = create "variables"; comma 0;
|
|
sub variable {
|
|
xlink $xvariables;
|
|
header shift(@_);
|
|
reveal;
|
|
return compile \&dovar, shift(@_);
|
|
}
|
|
|
|
sub alias {
|
|
my $cfa = $body[$wc-1];
|
|
header shift(@_);
|
|
reveal;
|
|
$body[$wc-1] = $cfa;
|
|
return $cfa;
|
|
}
|
|
|
|
|
|
my $xdefers = create "defers"; comma 0;
|
|
sub defer {
|
|
xlink $xdefers;
|
|
header shift(@_);
|
|
reveal;
|
|
return compile \&dodefer, shift(@_);
|
|
}
|
|
|
|
# ( a n -- ) packs chars at $m[$a..$a+n-1] into string which is returned.
|
|
sub string {
|
|
my $x2 = $s[$sp--]&$cell;
|
|
my $x1 = $s[$sp--]&$cell;
|
|
return pack "W*",@m[$x1..$x1+$x2-1];
|
|
}
|
|
|
|
# ( a -- n ) unpacks chars of string par to $m[$a..]
|
|
sub unstring {
|
|
my @arg = unpack "W*", $_[0];
|
|
$w = @arg;
|
|
(my $addr, $s[$sp]) = ($s[$sp], $w);
|
|
@m[$addr..$addr+$w-1] = @arg;
|
|
}
|
|
|
|
# -------- vocabularies search order -------- #FOLD00
|
|
|
|
only; definitions;
|
|
sub xalso { push @vocstack, $m[$xcontextstore]; }
|
|
primitive "also", \&xalso;
|
|
|
|
forth; definitions;
|
|
my $xlast = constant "last", $xlaststore;
|
|
|
|
constant "context", $xcontextstore;
|
|
constant "current", $xcurrentstore;
|
|
|
|
sub xprevious {
|
|
$m[$xcontextstore] = pop @vocstack if ($#vocstack >= 0);
|
|
}
|
|
primitive "previous", \&xprevious;
|
|
|
|
sub xonly {
|
|
$m[$xcontextstore] = $xonlyvoc;
|
|
@vocstack = $xonlyvoc;
|
|
}
|
|
my $xonly = primitive "only", \&xonly;
|
|
|
|
sub xdefinitions { $m[$xcurrentstore] = $m[$xcontextstore]; }
|
|
primitive "definitions", \&xdefinitions;
|
|
|
|
# -------- error handling -------- #FOLD00
|
|
|
|
|
|
my %throwmessage = (
|
|
-1 => "aborted",
|
|
-2 => "aborted",
|
|
-3 => "stack overflow",
|
|
-4 => "stack underflow",
|
|
-5 => "return stack overflow",
|
|
-6 => "return stack underflow",
|
|
# -7 => "do loops nested too deeply",
|
|
# -8 => "dictionary overflow",
|
|
-9 => "invalid memory address",
|
|
-10 => "division by zero",
|
|
-11 => "result out of range",
|
|
-12 => "argument type mismatch",
|
|
-13 => "word not found",
|
|
-14 => "use only during compilation",
|
|
-15 => "invalid forget",
|
|
-16 => "attempt to use zero-length string as name",
|
|
-17 => "pictured numeric output string overflow",
|
|
-18 => "parsed string overflow",
|
|
# -19 => "word name too long",
|
|
-20 => "write to a read-only location",
|
|
-21 => "unsupported operation",
|
|
-22 => "unstructured",
|
|
# -23 => "address alignment exception",
|
|
-24 => "invalid numeric argument",
|
|
-25 => "return stack imbalance",
|
|
-26 => "loop parameters unavailable",
|
|
-27 => "invalid recursion",
|
|
-28 => "user interrupt",
|
|
-29 => "compiler nesting",
|
|
-30 => "obsolescent feature",
|
|
-31 => ">BODY used on non-CREATEd definition",
|
|
-32 => "invalid name argument",
|
|
-33 => "Block read exception",
|
|
-34 => "Block write exception",
|
|
-35 => "Invalid block number",
|
|
-36 => "Invalid file position",
|
|
-37 => "File I/O exception",
|
|
-38 => "File not found",
|
|
|
|
# additional error messages:
|
|
-64 => "use only while interpreting",
|
|
-65 => "executed BODY> on a non-body address",
|
|
-67 => "TO must be used on a VALUE",
|
|
-72 => "Invalid memory region specifier, or heap corrupted",
|
|
);
|
|
|
|
# used by abort" to introduce new abort messages
|
|
sub xnewerror { # ( n1 a n2 -- )
|
|
$throwmessage{$s[$sp--]} = string;
|
|
}
|
|
primitive "newerror", \&xnewerror;
|
|
|
|
|
|
# executed at the end of word executed by catch.
|
|
sub xbrthrow0 {
|
|
($ip, $sp, $catchframe) = @r[$rp-2..$rp]; # restore previous catch context
|
|
$rp -= 3;
|
|
$s[$sp] = 0; # throw value 0
|
|
}
|
|
my $xbrthrow0 = compile unnamedprimitive \&xbrthrow0; # not a primitive - returning to.
|
|
|
|
sub xexecute { $w = $s[$sp--]; $m[$w](); }
|
|
my $xexecute = primitive "execute", \&xexecute;
|
|
|
|
|
|
# ( a -- x )
|
|
sub xcatch {
|
|
$rp += 3; # room for new catch frame
|
|
@r[$rp-2..$rp] = ($ip, $sp, $catchframe); # save previous catch context
|
|
$catchframe = $rp; # point to this catch frame
|
|
$r[++$rp] = $xbrthrow0; # inject return address to throw0
|
|
xexecute; # call word running under catch
|
|
}
|
|
my $xcatch = primitive "catch", \&xcatch;
|
|
|
|
|
|
# ( err -- )
|
|
sub throw {
|
|
my $exception = shift; # throw value other than 0?
|
|
if ($exception) {
|
|
if ($catchframe) { # does previous catch frame exist?
|
|
$rp = $catchframe; # yes: point to prev catch frame
|
|
($ip, $sp, $catchframe) = @r[$rp-2..$rp]; # restore previous catch context
|
|
$rp -= 3;
|
|
$s[$sp] = $exception; # return throw value
|
|
} else { # throw without catch: top level
|
|
die $exception;
|
|
}
|
|
}
|
|
}
|
|
sub xthrow { throw $s[$sp--]; }
|
|
my $xthrow = primitive "throw", \&xthrow;
|
|
|
|
hidden; definitions;
|
|
sub xbrerror { throw -1; }
|
|
sub xstackunderflow { throw -4; }
|
|
sub xbrnotfound { throw -13; }
|
|
my $xbrerror = primitive "(error)", \&xbrerror;
|
|
my $xstackunderflow = unnamedprimitive \&xstackunderflow;
|
|
my $xbrnotfound = primitive "(notfound)", \&xbrnotfound;
|
|
my $xnotfound = defer "notfound", $xbrnotfound;
|
|
my $xlastword = create "lastword"; allot 2;
|
|
forth; definitions;
|
|
my $xerror = defer "error", $xbrerror;
|
|
|
|
# -------- run time words: literals and flow control --------
|
|
|
|
hidden; definitions;
|
|
sub xlit { $s[++$sp] = $m[$ip++]; }
|
|
my $xlit = primitive "(lit)", \&xlit;
|
|
|
|
sub xslit {
|
|
my $count = $m[$ip++];
|
|
$sp += 2;
|
|
@s[$sp-1..$sp] = ($ip, $count);
|
|
$ip += $count;
|
|
}
|
|
my $xslit = primitive '(slit)', \&xslit;
|
|
|
|
sub xbrdotquote { xslit; print string; }
|
|
my $xbrdotquote = primitive '(.")', \&xbrdotquote;
|
|
|
|
|
|
sub xbranch { $ip += $m[$ip]; }
|
|
my $xbranch = primitive "(branch)", \&xbranch;
|
|
|
|
sub xbranch0 {
|
|
if ($s[$sp--]) {
|
|
$ip++;
|
|
} else {
|
|
$ip += $m[$ip];
|
|
}
|
|
}
|
|
my $xbranch0 = primitive "(0branch)", \&xbranch0;
|
|
|
|
sub xbrfor {
|
|
$r[++$rp] = $s[$sp]-1;
|
|
$r[++$rp] = $s[$sp--]-1;
|
|
$ip++;
|
|
}
|
|
my $xbrfor = primitive "(for)", \&xbrfor;
|
|
|
|
sub xbrnext {
|
|
if ($r[$rp]--) {
|
|
$ip += $m[$ip];
|
|
} else {
|
|
$rp -= 2;
|
|
$ip++;
|
|
}
|
|
}
|
|
my $xbrnext = primitive "(next)", \&xbrnext;
|
|
|
|
sub xbrdo {
|
|
$rp += 2;
|
|
@r[$rp-1..$rp] = @s[$sp-1..$sp];
|
|
$sp -= 2;
|
|
$ip++;
|
|
}
|
|
|
|
|
|
my $xbrdo = primitive "(do)", \&xbrdo;
|
|
|
|
sub xbrqdo {
|
|
if ($s[$sp] == $s[$sp-1]) {
|
|
$ip += $m[$ip];
|
|
} else {
|
|
$rp += 2;
|
|
@r[$rp-1..$rp] = @s[$sp-1..$sp];
|
|
$ip++ ;
|
|
}
|
|
$sp -= 2;
|
|
}
|
|
my $xbrqdo = primitive "(?do)", \&xbrqdo;
|
|
|
|
sub xbrleave {
|
|
$rp -= 2;
|
|
$ip = $m[$ip];
|
|
$ip += $m[$ip];
|
|
}
|
|
my $xbrleave = primitive "(leave)", \&xbrleave;
|
|
|
|
sub xbrqleave {
|
|
if ($s[$sp--]) {
|
|
xbrleave;
|
|
} else {
|
|
$ip++;
|
|
}
|
|
}
|
|
my $xbrqleave = primitive "(?leave)", \&xbrqleave;
|
|
|
|
sub xbrloop {
|
|
if (++$r[$rp] != $r[$rp-1]) { # index+1 != limit
|
|
$ip += $m[$ip]; # add branch offset to instruction pointer
|
|
} else {
|
|
$rp -= 2; # discard loop parameters
|
|
$ip++; # skip branch offset
|
|
}
|
|
}
|
|
my $xbrloop = primitive "(loop)", \&xbrloop;
|
|
|
|
sub xbrplusloop { # determine loop exit condition by simulating sign overflow:
|
|
$w = $r[$rp] - $r[$rp-1]; # temp = index-limit
|
|
$r[$rp] += $s[$sp--]; # index += loop increment
|
|
if ((($r[$rp] - $r[$rp-1]) ^ $w) < $msb) { # sign change of index-limit before and after?
|
|
$ip += $m[$ip]; # no: add branch offset to instruction pointer
|
|
} else {
|
|
$rp -= 2; # yes: exit loop: discard loop parameters
|
|
$ip++; # skip branch offset
|
|
}
|
|
}
|
|
my $xbrplusloop = primitive "(+loop)", \&xbrplusloop;
|
|
|
|
sub xbrunloop { $rp -= 2; }
|
|
my $xbrunloop = primitive "(unloop)", \&xbrunloop;
|
|
|
|
sub doarray {
|
|
if (($s[$sp] < $m[$w+1]) && ($s[$sp] >= -1)) { # legal index. -1 addresses array size
|
|
$s[$sp] += ($w+2); # index > address
|
|
} else {
|
|
throw -24;
|
|
}
|
|
}
|
|
|
|
my $xarrays = create "arrays"; comma 0;
|
|
sub array {
|
|
xlink $xarrays;
|
|
header shift(@_);
|
|
reveal;
|
|
my $cfa = compile \&doarray;
|
|
my $count = shift(@_);
|
|
comma $count;
|
|
allot $count;
|
|
return $cfa;
|
|
}
|
|
|
|
forth; definitions;
|
|
|
|
# -------- constants, variables -------- #FOLD00
|
|
|
|
my $xesc = constant "esc", 27;
|
|
my $xbl = constant "bl", 32;
|
|
my $xfalse = constant "false", 0;
|
|
my $xzero = alias "0";
|
|
my $xtrue = constant "true", -1;
|
|
my $xminusone = alias "-1";
|
|
constant "msb", $msb;
|
|
constant "maxu", $maxu;
|
|
my $xstate = variable "state", 0;
|
|
my $xbase = variable "base", 10;
|
|
my $xhashtib = variable "#tib", 0;
|
|
my $xtoin = variable ">in", 0;
|
|
my $xinnerloop = variable "innerloop", 0;
|
|
my $xtib = create "tib"; allot $tibsize;
|
|
constant "version", int $version;
|
|
constant "tibsize", $tibsize;
|
|
my $xkeytable = array "keytable", 32;
|
|
|
|
|
|
# -------- stack handling --------
|
|
|
|
|
|
sub xdrop { $sp--; }
|
|
sub xrdrop { $rp--; }
|
|
sub x2drop { $sp -= 2; }
|
|
sub xsp { $s[++$sp] = $sp; }
|
|
sub xrp { $s[++$sp] = $rp; }
|
|
sub xdup { $s[++$sp] = $s[$sp]; }
|
|
sub xqdup { $s[++$sp] = $s[$sp] if ( $s[$sp]); }
|
|
sub xover { $s[++$sp] = $s[$sp-1]; }
|
|
sub xnip { $s[$sp] = $s[$sp--]; }
|
|
sub xpick { $s[$sp] = $s[$sp-$s[$sp]-1]; }
|
|
sub xdepth { $s[++$sp] = $sp; }
|
|
sub xswap { @s[$sp-1..$sp] = ($s[$sp], $s[$sp-1]); }
|
|
sub xrot { @s[$sp-2, $sp-1, $sp] = @s[$sp-1, $sp, $sp-2]; }
|
|
sub x2dup { $sp += 2; @s[$sp-1..$sp] = @s[$sp-3..$sp-2]; }
|
|
sub x2over { $sp += 2; @s[$sp-1..$sp] = @s[$sp-5..$sp-4]; }
|
|
sub x2swap { @s[$sp-3..$sp] = (@s[$sp-1..$sp], @s[$sp-3..$sp-2]);}
|
|
sub xtor { $r[++$rp] = $s[$sp--]; }
|
|
sub xrfrom { $s[++$sp] = $r[$rp--]; }
|
|
sub xrfetch { $s[++$sp] = $r[$rp]; }
|
|
sub x2tor { $r[++$rp] = $s[$sp--];
|
|
$r[++$rp] = $s[$sp--]; }
|
|
sub x2rfrom { $s[++$sp] = $r[$rp--];
|
|
$s[++$sp] = $r[$rp--]; }
|
|
sub x2rfetch { $s[++$sp] = $r[$rp];
|
|
$s[++$sp] = $r[$rp-1]; }
|
|
|
|
|
|
my $xdup = primitive "dup", \&xdup;
|
|
my $xqdup = primitive "?dup", \&xqdup;
|
|
my $xdrop = primitive "drop", \&xdrop;
|
|
my $xover = primitive "over", \&xover;
|
|
my $xswap = primitive "swap", \&xswap;
|
|
my $xrot = primitive "rot", \&xrot;
|
|
my $xnip = primitive "nip", \&xnip;
|
|
my $x2dup = primitive "2dup", \&x2dup;
|
|
my $x2drop = primitive "2drop", \&x2drop;
|
|
my $x2swap = primitive "2swap", \&x2swap;
|
|
my $x2over = primitive "2over", \&x2over;
|
|
my $xpick = primitive "pick", \&xpick;
|
|
my $xdepth = primitive "depth", \&xdepth;
|
|
my $xtor = primitive ">r", \&xtor;
|
|
my $xrfrom = primitive "r>", \&xrfrom;
|
|
my $xrfetch = primitive "r@", \&xrfetch;
|
|
my $xrdrop = primitive "rdrop", \&xrdrop;
|
|
my $x2tor = primitive "2>r", \&x2tor;
|
|
my $x2rfrom = primitive "2r>", \&x2rfrom;
|
|
my $x2rfetch = primitive "2r@", \&x2rfetch;
|
|
primitive "rp", \&xrp;
|
|
primitive "sp", \&xsp;
|
|
|
|
|
|
# -------- flow control -------- #FOLD00
|
|
|
|
|
|
my $xexit = primitive "exit", \&unnest;
|
|
|
|
sub xi { $s[++$sp] = $r[$rp]; }
|
|
my $xi = primitive "i", \ξ
|
|
|
|
sub xj { $s[++$sp] = $r[$rp-2]; }
|
|
my $xj = primitive "j", \&xj;
|
|
|
|
sub xuse { $m[$body[$wc-1]] = $s[$sp--]; }
|
|
my $xuse = primitive "use", \&xuse;
|
|
|
|
sub xunless { $ip = $r[$rp--] if ($s[$sp--]) }
|
|
my $xunless = primitive "unless", \&xunless;
|
|
|
|
sub xbye { print "\n"; exit; }
|
|
my $xbye = primitive "bye", \&xbye;
|
|
|
|
|
|
sub XIF {
|
|
comma $xbranch0;
|
|
$s[++$sp] = $dp++;
|
|
}
|
|
|
|
sub XELSE {
|
|
comma $xbranch;
|
|
my $offs = $s[$sp];
|
|
$s[$sp] = $dp++;
|
|
$m[$offs] = $dp-$offs;
|
|
}
|
|
|
|
sub XTHEN {
|
|
$m[$s[$sp]] = $dp-$s[$sp];
|
|
$sp--;
|
|
}
|
|
|
|
sub XBEGIN {
|
|
$s[++$sp] = $dp;
|
|
}
|
|
|
|
sub XAGAIN {
|
|
comma $xbranch;
|
|
comma $s[$sp--]-$dp;
|
|
}
|
|
|
|
sub XUNTIL {
|
|
comma $xbranch0;
|
|
comma $s[$sp--]-$dp;
|
|
}
|
|
|
|
sub XWHILE {
|
|
XIF;
|
|
}
|
|
|
|
sub XREPEAT {
|
|
xswap;
|
|
XAGAIN;
|
|
XTHEN;
|
|
}
|
|
|
|
|
|
# -------- bitwise logic -------- #FOLD00
|
|
|
|
sub xand {
|
|
$s[$sp-1] &= ($s[$sp--] % $wrap);
|
|
$s[$sp]-=$wrap if $s[$sp]>=$msb;
|
|
}
|
|
my $xand = primitive "and", \&xand;
|
|
|
|
sub xor {
|
|
$s[$sp-1] |= ($s[$sp--] % $wrap);
|
|
$s[$sp]-=$wrap if $s[$sp]>=$msb;
|
|
}
|
|
my $xor = primitive "or", \&xor;
|
|
|
|
sub xxor {
|
|
$s[$sp-1] ^= ($s[$sp--] % $wrap);
|
|
$s[$sp]-=$wrap if $s[$sp]>=$msb;
|
|
}
|
|
my $xxor = primitive "xor", \&xxor;
|
|
|
|
sub xinvert {
|
|
$s[$sp] ^= -1;
|
|
$s[$sp]-=$wrap if $s[$sp]>=$msb;
|
|
}
|
|
my $xinvert = primitive "invert", \&xinvert;
|
|
|
|
sub x2mul {
|
|
$s[$sp] <<= 1;
|
|
$s[$sp]-=$wrap if $s[$sp]>=$msb;
|
|
}
|
|
my $x2mul = primitive "2*", \&x2mul;
|
|
|
|
sub x2div {
|
|
$s[$sp] >>= 1;
|
|
}
|
|
my $x2div = primitive "2/", \&x2div;
|
|
|
|
sub xrshift {
|
|
$s[$sp-1] >>= ($s[$sp--] & $bits-1);
|
|
}
|
|
my $xrshift = primitive "rshift", \&xrshift;
|
|
alias ">>";
|
|
|
|
sub xlshift {
|
|
$s[$sp-1] <<= ($s[$sp--] & $bits-1);
|
|
$s[$sp]%=$wrap;
|
|
$s[$sp]-=$wrap if $s[$sp]>=$msb;
|
|
}
|
|
my $xlshift = primitive "lshift", \&xlshift;
|
|
alias "<<";
|
|
|
|
|
|
|
|
# -------- comparison --------
|
|
|
|
|
|
sub xequals { $s[--$sp] = -($s[$sp] == $s[$sp-1]); }
|
|
my $xequals = primitive "=", \&xequals;
|
|
|
|
sub xnotequals { $s[--$sp] = -($s[$sp] != $s[$sp-1]); }
|
|
my $xnotequals = primitive "<>", \&xnotequals;
|
|
|
|
sub xless { my $tos = $s[$sp--]; $s[$sp] = -($s[$sp] < $tos); }
|
|
my $xless = primitive "<", \&xless;
|
|
|
|
sub xuless { my $tos = $s[$sp--]|0; $s[$sp] = -(($s[$sp]|0) < $tos); }
|
|
my $xuless = primitive "u<", \&xuless;
|
|
|
|
sub xgreater { my $tos = $s[$sp--]; $s[$sp] = -($s[$sp] > $tos); }
|
|
my $xgreater = primitive ">", \&xgreater;
|
|
|
|
sub xugreater { my $tos = $s[$sp--]|0; $s[$sp] = -(($s[$sp]|0) > $tos); }
|
|
my $xugreater = primitive "u>", \&xugreater;
|
|
|
|
sub xzeroequals { $s[$sp] = -(!$s[$sp]); }
|
|
my $xzeroequals = primitive "0=", \&xzeroequals;
|
|
|
|
sub xzeronotequals { $s[$sp] = -(!!$s[$sp]); }
|
|
my $xzeronotequals = primitive "0<>", \&xzeronotequals;
|
|
|
|
sub xzeroless { $s[$sp] = -($s[$sp] < 0); }
|
|
my $xzeroless = primitive "0<", \&xzeroless;
|
|
|
|
sub xzeromore { $s[$sp] = -($s[$sp] > 0); }
|
|
my $xzeromore = primitive "0>", \&xzeromore;
|
|
|
|
|
|
# -------- arithmetic --------
|
|
|
|
|
|
sub xoneplus {
|
|
$s[$sp]++;
|
|
$s[$sp] -= $wrap if $s[$sp] >= $msb;
|
|
}
|
|
my $xoneplus = primitive "1+", \&xoneplus;
|
|
|
|
sub xoneminus {
|
|
$s[$sp]--;
|
|
$s[$sp] += $wrap if $s[$sp] < -$msb;
|
|
}
|
|
my $xoneminus = primitive "1-", \&xoneminus;
|
|
|
|
|
|
sub xplus {
|
|
$s[$sp-1] += $s[$sp--];
|
|
$s[$sp]%=$wrap;
|
|
$s[$sp]-=$wrap if $s[$sp] >= $msb;
|
|
}
|
|
my $xplus = primitive "+", \&xplus;
|
|
|
|
sub xminus {
|
|
$s[$sp-1] -= $s[$sp--];
|
|
$s[$sp]%=$wrap;
|
|
$s[$sp]-=$wrap if $s[$sp] >= $msb;
|
|
}
|
|
my $xminus = primitive "-", \&xminus;
|
|
|
|
sub xmul {
|
|
$s[$sp-1] *= $s[$sp--];
|
|
$s[$sp]%=$wrap;
|
|
$s[$sp]-=$wrap if $s[$sp] >= $msb;
|
|
}
|
|
my $xmul = primitive "*", \&xmul;
|
|
|
|
sub xdiv {
|
|
if (!$s[$sp]) { throw -10; }
|
|
$s[$sp-1] /= $s[$sp--];
|
|
}
|
|
my $xdiv = primitive "/", \&xdiv;
|
|
|
|
sub xmod {
|
|
if (!$s[$sp]) { throw -10; }
|
|
$s[$sp-1] %= $s[$sp--];
|
|
}
|
|
my $xmod = primitive "mod", \&xmod;
|
|
|
|
sub xstarslash {
|
|
if (!$s[$sp]) { throw -10; }
|
|
$s[$sp-2] *= $s[$sp-1];
|
|
$s[$sp-2] /= $s[$sp];
|
|
$sp -= 2;
|
|
$s[$sp]%=$wrap;
|
|
$s[$sp]-=$wrap if $s[$sp] >= $msb;
|
|
}
|
|
my $xstarslash = primitive "*/", \&xstarslash;
|
|
|
|
# ( n1 n2 -- n3 n4 )
|
|
sub xslashmod {
|
|
@s[$sp-1..$sp] = ($s[$sp-1]%$s[$sp], int $s[$sp-1]/$s[$sp]);
|
|
}
|
|
my $xslashmod = primitive "/mod", \&xslashmod;
|
|
|
|
|
|
# ( n1 n2 -- n3 n4 )
|
|
sub xuslashmod {
|
|
$s[$sp-1]%=$wrap;
|
|
@s[$sp-1..$sp] = ($s[$sp-1]%$s[$sp], int $s[$sp-1]/$s[$sp]);
|
|
}
|
|
my $xuslashmod = primitive "u/mod", \&xuslashmod;
|
|
|
|
|
|
sub xstarslashmod {
|
|
if (!$s[$sp]) { throw -10; }
|
|
$s[$sp-2] *= $s[$sp-1];
|
|
@s[$sp-2..$sp-1] = ($s[$sp-2]%$s[$sp], int $s[$sp-2]/$s[$sp]);
|
|
$s[$sp]%=$wrap;
|
|
$s[$sp]-=$wrap if $s[$sp] >= $msb;
|
|
$sp--;
|
|
}
|
|
my $xstarslashmod = primitive "*/mod", \&xstarslashmod;
|
|
|
|
sub xabs { $s[$sp] = abs($s[$sp]); }
|
|
my $xabs = primitive "abs", \&xabs;
|
|
|
|
sub xnegate { $s[$sp] = -$s[$sp]; }
|
|
my $xnegate = primitive "negate", \&xnegate;
|
|
|
|
|
|
# -------- memory access -------- #FOLD00
|
|
|
|
|
|
sub xfetch { $s[$sp] = $m[$s[$sp]&$cell]; }
|
|
my $xfetch = primitive "@", \&xfetch;
|
|
|
|
sub xcfetch { $s[$sp] = $m[$s[$sp]&$cell] & 255; }
|
|
my $xcfetch = primitive "c@", \&xcfetch;
|
|
|
|
# ( a -- d )
|
|
sub x2fetch {
|
|
my $addr = $s[$sp++]&$cell;
|
|
@s[$sp-1..$sp] = @m[$addr..$addr+1];
|
|
}
|
|
my $x2fetch = primitive "2@", \&x2fetch;
|
|
|
|
sub xstore {
|
|
$m[$s[$sp]&$cell] = $s[$sp-1];
|
|
$sp-=2;
|
|
}
|
|
my $xstore = primitive "!", \&xstore;
|
|
|
|
sub xcstore {
|
|
$m[$s[$sp]&$cell] = $s[$sp-1] & 255;
|
|
$sp-=2;
|
|
}
|
|
my $xcstore = primitive "c!", \&xcstore;
|
|
|
|
# ( d a -- )
|
|
sub x2store {
|
|
my $addr = $s[$sp--]&$cell;
|
|
@m[$addr..$addr+1] = @s[$sp-1..$sp];
|
|
$sp -= 2
|
|
}
|
|
my $x2store = primitive "2!", \&x2store;
|
|
|
|
sub xplusstore {
|
|
$m[$s[$sp]&$cell] += $s[$sp-1];
|
|
$sp-=2;
|
|
}
|
|
my $xplusstore = primitive "+!", \&xplusstore;
|
|
|
|
sub xcount { $s[++$sp] = $m[$s[$sp]++&$cell] & 255; }
|
|
my $xcount = primitive "count", \&xcount;
|
|
|
|
sub xskim { $s[++$sp] = $m[$s[$sp]++&$cell]; }
|
|
my $xskim = primitive "skim", \&xskim;
|
|
|
|
sub xon { $m[$s[$sp--]&$cell] = -1; }
|
|
my $xon = primitive "on", \&xon;
|
|
|
|
sub xoff { $m[$s[$sp--]&$cell] = 0; }
|
|
my $xoff = primitive "off", \&xoff;
|
|
|
|
# ( x1 a -- x2 )
|
|
sub xexchange {
|
|
my $addr = $s[$sp--]&$cell;
|
|
($m[$addr], $s[$sp]) = ($s[$sp], $m[$addr]);
|
|
}
|
|
my $xexchange = primitive "exchange", \&xexchange;
|
|
|
|
# ( a1 n1 c -- a2 n2 )
|
|
sub xskip {
|
|
my $char = $s[$sp--];
|
|
(my $addr, my $len) = @s[$sp-1..$sp];
|
|
while (($m[$addr&$cell] == $char) && ($len)) {
|
|
$addr++;
|
|
$len--;
|
|
}
|
|
@s[$sp-1..$sp] = ($addr, $len);
|
|
}
|
|
my $xskip = primitive "skip", \&xskip;
|
|
|
|
# ( a1 n1 c -- a2 n2 )
|
|
sub xscan {
|
|
my $char = $s[$sp--];
|
|
(my $addr, my $len) = @s[$sp-1..$sp];
|
|
while (($m[$addr&$cell] != $char) && ($len)) {
|
|
$addr++;
|
|
$len--;
|
|
}
|
|
@s[$sp-1..$sp] = ($addr, $len);
|
|
}
|
|
my $xscan = primitive "scan", \&xscan;
|
|
|
|
# ( src dst n -- )
|
|
sub xmove {
|
|
(my $src, my $dest, my $count) = @s[$sp-2..$sp];
|
|
@m[$dest..$dest+$count-1] = @m[$src..$src+$count-1];
|
|
$sp-=3;
|
|
}
|
|
my $xmove = primitive "move", \&xmove;
|
|
|
|
# ( a n c -- )
|
|
sub xfill {
|
|
(my $dest, my $count, my $char) = @s[$sp-2..$sp];
|
|
@m[$dest..$dest+$count-1] = ($char) x $count;
|
|
$sp-=3;
|
|
}
|
|
my $xfill = primitive "fill", \&xfill;
|
|
|
|
|
|
|
|
# -------- number conversion -------- #FOLD00
|
|
|
|
|
|
my %radixprefix = (
|
|
'%' => 2,
|
|
'&' => 8,
|
|
'#' => 10,
|
|
'$' => 16,
|
|
'_' => 36,
|
|
);
|
|
|
|
# ( a n -- x -1 | 0 )
|
|
sub xqnumber {
|
|
my $sign = 0;
|
|
my $accu = 0; # accumulator
|
|
my $valid = -1; # assume valid number
|
|
|
|
my $i = $s[$sp--]; # number of digits to test/convert
|
|
$w = $s[$sp--]; # addr of next digit
|
|
|
|
if ($m[$w] == 45) { # leading -
|
|
$sign--;
|
|
$w++; # strip
|
|
$i--;
|
|
}
|
|
|
|
my $radix = $m[$xbase+1]; # assume radix from base
|
|
if (defined $radixprefix{chr $m[$w]}) { # but if radix prefix,
|
|
$radix = $radixprefix{chr $m[$w]}; # use radix for prefix
|
|
$w++; # strip prefix
|
|
$i--;
|
|
}
|
|
|
|
for (; $i; $i--) { # for all digits
|
|
my $digit = $m[$w++] - 48; # read digit
|
|
if (($digit < 0) || (($digit > 9) && ($digit < 17))) {
|
|
$valid = 0;
|
|
last;
|
|
}
|
|
$digit -= 7 if ($digit > 9 ); # remove gap between 9 and A
|
|
$digit -= 32 if ($digit > 41); # a..z -> A..Z
|
|
if (($digit < 0) || ($digit >= $radix)) {
|
|
$valid = 0;
|
|
last;
|
|
}
|
|
($accu *= $radix) += $digit;
|
|
}
|
|
|
|
if ($valid) {
|
|
$accu = -$accu if ($sign);
|
|
$accu %= $wrap;
|
|
$accu -= $wrap if $accu >= $msb;
|
|
$s[++$sp] = $accu;
|
|
}
|
|
$s[++$sp] = $valid;
|
|
}
|
|
my $xqnumber = primitive "?number", \&xqnumber;
|
|
|
|
# -------- output -------- #FOLD00
|
|
|
|
|
|
sub xcr { print "\n"; }
|
|
my $xcr = primitive "cr", \&xcr;
|
|
|
|
sub xemit { printf "%c",$s[$sp--]; }
|
|
my $xemit = primitive "emit", \&xemit;
|
|
|
|
sub xdotslit { print $m[$ip++]; }
|
|
my $xdotslit = unnamedprimitive \&xdotslit;
|
|
|
|
sub xspace { print " "; }
|
|
my $xspace = primitive "space", \&xspace;
|
|
|
|
# ( a n -- )
|
|
sub xtype { print string; }
|
|
my $xtype = primitive "type", \&xtype;
|
|
|
|
|
|
# -------- character input -------- #FOLD00
|
|
|
|
|
|
|
|
my $keybuffer;
|
|
# ( -- c ) lowest level key input word
|
|
sub xbrkey {
|
|
my $key = $keybuffer;
|
|
$keybuffer = 0;
|
|
if (!$key) {
|
|
ReadMode 4;
|
|
$key = ReadKey(0);
|
|
ReadMode 0;
|
|
}
|
|
$s[++$sp] = ord $key;
|
|
}
|
|
my $xbrkey = primitive "(key)", \&xbrkey;
|
|
my $xkey = defer "key", $xbrkey;
|
|
|
|
|
|
sub xqkey {
|
|
if ($keybuffer) {
|
|
$s[++$sp] = -1;
|
|
} else {
|
|
ReadMode 4;
|
|
$keybuffer = ReadKey(-1); # possible race condition resulting in occasional echoing
|
|
ReadMode 0;
|
|
$s[++$sp] = -(defined $keybuffer);
|
|
}
|
|
}
|
|
my $xqkey = primitive "key?", \&xqkey;
|
|
|
|
|
|
# -------- buffered I/O -------- #FOLD00
|
|
|
|
|
|
# read string, delimited by c. return address and len
|
|
# updates source
|
|
# ( c -- a n )
|
|
sub xparse {
|
|
my $delimiter = $s[$sp];
|
|
my $bufend = $parsebuf + $parsebuflen; # first non-buf address
|
|
$w = $m[$xtoin+1] + $parsebuf; # parse address
|
|
my $nxtchar = $m[$w];
|
|
if ($delimiter == 32) {
|
|
for (; $w < $bufend;) {
|
|
last if (!(defined $nxtchar));
|
|
last if ($nxtchar != $delimiter);
|
|
$w++;
|
|
$nxtchar = $m[$w];
|
|
}
|
|
}
|
|
$s[$sp] = $w;
|
|
for (; $w < $bufend;) {
|
|
last if (!(defined $nxtchar) || ($nxtchar == $delimiter));
|
|
$nxtchar = $m[++$w];
|
|
}
|
|
$s[++$sp] = $w - $s[$sp];
|
|
$w++ if ((defined $nxtchar) && ($nxtchar == $delimiter));
|
|
$m[$xtoin+1] = $w - $parsebuf;
|
|
}
|
|
my $xparse = primitive "parse", \&xparse;
|
|
|
|
sub xsource {
|
|
$sp += 2;
|
|
@s[$sp-1..$sp] = ($parsebuf, $parsebuflen);
|
|
}
|
|
my $xsource = primitive "source", \&xsource;
|
|
|
|
hidden; definitions;
|
|
# ( addr len offs -- )
|
|
sub xpushsource {
|
|
push @sourcestack, $m[$xtoin+1], $parsebuf, $parsebuflen;
|
|
$m[$xtoin+1] = 0;
|
|
($parsebuf, $parsebuflen) = @s[$sp-1..$sp];
|
|
$sp -= 2;
|
|
}
|
|
my $xpushsource = primitive "pushsource", \&xpushsource;
|
|
|
|
sub xpopsource {
|
|
$parsebuflen = pop @sourcestack;
|
|
$parsebuf = pop @sourcestack;
|
|
$m[$xtoin+1] = pop @sourcestack;
|
|
}
|
|
my $xpopsource = primitive "popsource", \&xpopsource;
|
|
|
|
|
|
# ( a n1 asc -- a n2 )
|
|
my $xdecode = colon "decode";
|
|
compile $xdup, $xlit, 127, $xequals; # Del/BS: remove previous
|
|
compile $xover, $xlit, 8, $xequals, $xor;
|
|
XIF; compile $xdrop;
|
|
compile $xdup;
|
|
XIF; compile $xdotslit, "\b \b", $xoneminus; XTHEN;
|
|
compile $xexit;
|
|
XTHEN;
|
|
compile $xdup, $xlit, 9, $xequals; # Tab: convert to space
|
|
XIF; compile $xdrop, $xbl; XTHEN;
|
|
compile $xdup, $xemit; # echo char
|
|
compile $xtor, $x2dup, $xplus; # calc buffer address
|
|
compile $xrfrom, $xswap, $xstore; # buffer char
|
|
compile $xoneplus; # count
|
|
semicolon;
|
|
forth; definitions;
|
|
|
|
|
|
# -------- dictionary and compilation -------- #FOLD00
|
|
|
|
|
|
sub xhere { $s[++$sp] = $dp; }
|
|
my $xhere = primitive "here", \&xhere;
|
|
|
|
sub xallot { $dp += $s[$sp--]; }
|
|
my $xallot = primitive "allot", \&xallot;
|
|
|
|
sub xcomma { $m[$dp++&$cell] = $s[$sp--]; }
|
|
my $xcomma = primitive ",", \&xcomma;
|
|
|
|
my $xstateoff = colon '['; immediate;
|
|
compile $xstate, $xoff;
|
|
semicolon;
|
|
|
|
my $xstateon = colon "]";
|
|
compile $xstate, $xon;
|
|
semicolon;
|
|
|
|
my $xcompiling = colon "compiling";
|
|
compile $xstate, $xfetch;
|
|
semicolon;
|
|
|
|
my $xqcomp = colon "?comp";
|
|
compile $xcompiling, $xzeroequals;
|
|
compile $xlit, -14, $xand, $xthrow;
|
|
semicolon;
|
|
|
|
my $xqexec = colon "?exec";
|
|
compile $xcompiling;
|
|
compile $xlit, -64, $xand, $xthrow;
|
|
semicolon;
|
|
|
|
|
|
# -------- vocabulary/wordlist -------- #FOLD00
|
|
|
|
|
|
sub xheader { header string }
|
|
my $xheader = primitive "header", \&xheader;
|
|
my $xhide = primitive "hide", \&hide;
|
|
my $xreveal = primitive "reveal" , \&reveal;
|
|
my $ximmediate = primitive "immediate", \&immediate;
|
|
|
|
# ( header -- f )
|
|
sub xqimm {
|
|
$s[$sp] = -(!!($precedence[$s[$sp]] & $precedencebit));
|
|
}
|
|
my $xqimm = primitive "?imm", \&xqimm;
|
|
|
|
sub xwords {
|
|
my $nfa = $m[$m[$xcontextstore]+2];
|
|
while ($nfa) {
|
|
print "$header[$nfa] ";
|
|
$nfa = $voclink[$nfa];
|
|
}
|
|
xcr;
|
|
}
|
|
only; definitions;
|
|
my $xwords = primitive "words", \&xwords;
|
|
forth; definitions;
|
|
|
|
sub xnamefrom { $s[$sp] = $body[$s[$sp]]; }
|
|
my $xnamefrom = primitive "name>", \&xnamefrom;
|
|
|
|
|
|
hidden; definitions;
|
|
# returns matching header index, aka nfa, (or 0)
|
|
# ( a1 n -- a2 | 0 )
|
|
sub xbrhunt {
|
|
my $name = string;
|
|
$s[++$sp] = 0;
|
|
my $last = $m[$m[$xcontextstore]+2];
|
|
while ($last) {
|
|
if ($precedence[$last] & $revealbit) {
|
|
if ($header[$last] eq $name) {
|
|
$s[$sp] = $last;
|
|
last;
|
|
}
|
|
}
|
|
$last = $voclink[$last]
|
|
}
|
|
}
|
|
my $xbrhunt = primitive "(hunt)", \&xbrhunt;
|
|
forth; definitions;
|
|
|
|
sub xhunt {
|
|
x2dup; xbrhunt;
|
|
if (!($s[$sp])) {
|
|
my $prevcontext = $m[$xcontextstore];
|
|
my $vocstackdepth = $#vocstack;
|
|
for my $voc (0..$vocstackdepth) {
|
|
my $tempcontext = $vocstack[$vocstackdepth-$voc];
|
|
if ($tempcontext != $prevcontext) {
|
|
xdrop;
|
|
$m[$xcontextstore] = $tempcontext;
|
|
x2dup; xbrhunt;
|
|
last if ($s[$sp]);
|
|
}
|
|
}
|
|
$m[$xcontextstore] = $prevcontext;
|
|
}
|
|
xnip; xnip;
|
|
}
|
|
my $xhunt = primitive "hunt", \&xhunt;
|
|
|
|
|
|
|
|
|
|
# returns matching header index, aka nfa, (or 0)
|
|
# ( cfa -- a | 0 )
|
|
sub xtoname {
|
|
my $cfa = $s[$sp];
|
|
$s[$sp] = 0;
|
|
for (my $i=$wc-1; $i; --$i) {
|
|
if ($body[$i] eq $cfa) {
|
|
$s[$sp] = $i;
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
my $xtoname = primitive ">name", \&xtoname;
|
|
|
|
|
|
# ( cfa -- a n )
|
|
sub xname {
|
|
xtoname;
|
|
my $nfa = $s[$sp];
|
|
$s[$sp] = $dp;
|
|
$s[++$sp] = 0;
|
|
if ($nfa) {
|
|
$s[$sp] = $dp;
|
|
unstring $header[$nfa];
|
|
}
|
|
}
|
|
my $xname = primitive "name", \&xname;
|
|
|
|
|
|
# ( cfa -- )
|
|
sub xdotname {
|
|
xtoname;
|
|
print $header[$s[$sp]] if ($s[$sp]);
|
|
$sp--; }
|
|
my $xdotname = primitive ".name", \&xdotname;
|
|
|
|
sub xorder {
|
|
print "\ncontext: ";
|
|
$s[++$sp] = $m[$xcontextstore];
|
|
xdotname; xspace; xspace;
|
|
my $vocstackdepth = $#vocstack;
|
|
for my $voc (0..$vocstackdepth) {
|
|
$s[++$sp] = $vocstack[$vocstackdepth-$voc];
|
|
xdotname; xspace;
|
|
}
|
|
$s[++$sp] = $m[$xcurrentstore];
|
|
print "\ncurrent: ";
|
|
xdotname; xspace; xcr;
|
|
}
|
|
only; definitions;
|
|
my $xorder = primitive "order", \&xorder;
|
|
forth; definitions;
|
|
|
|
my $xtick = colon "'";
|
|
compile $xbl, $xparse;
|
|
compile $x2dup, $xlastword, $x2store;
|
|
compile $xhunt;
|
|
compile $xqdup;
|
|
XIF; compile $xnamefrom;
|
|
XELSE; compile $xnotfound;
|
|
XTHEN;
|
|
semicolon;
|
|
|
|
|
|
my $xcreate = colon "create";
|
|
compile $xbl, $xparse;
|
|
compile $xqdup, $xzeroequals, $xlit, -16, $xand, $xthrow;
|
|
compile $xheader, $xlit, \&dovar, $xcomma;
|
|
compile $xreveal;
|
|
semicolon;
|
|
|
|
|
|
my $xcolon = colon ":"; immediate;
|
|
compile $xcompiling, $xlit, -29, $xand, $xthrow;
|
|
compile $xcreate, $xhide;
|
|
compile $xlit, \&nest, $xuse;
|
|
compile $xstateon;
|
|
semicolon;
|
|
|
|
|
|
my $xsemicolon = colon ";"; immediate;
|
|
compile $xqcomp, $xlit, $xexit, $xcomma,
|
|
$xstateoff, $xreveal;
|
|
semicolon;
|
|
|
|
|
|
# -------- misc -------- #FOLD00
|
|
|
|
|
|
sub xepoch { $s[++$sp] = time; }
|
|
my $xepoch = primitive "epoch", \&xepoch;
|
|
|
|
|
|
my $xstructured = colon "structured";
|
|
compile $x2dup, $xnotequals;
|
|
compile $xlit, -22, $xand, $xthrow;
|
|
compile $x2drop;
|
|
semicolon;
|
|
|
|
sub xdefined { $s[$sp] = -(defined $s[$sp]); }
|
|
my $xdefined = primitive "defined", \&xdefined;
|
|
|
|
# ( a n -- x )
|
|
sub xshell {
|
|
print "\n";
|
|
system string;
|
|
}
|
|
primitive "shell", \&xshell;
|
|
|
|
|
|
# -------- does> -------- #FOLD00
|
|
|
|
sub xdodoes { # cfa of created word revectored here.
|
|
$s[++$sp] = $w+1; # push data address of created word
|
|
$r[++$rp] = $ip; # nest to hilevel code behind does>
|
|
$ip = $does{$w};
|
|
}
|
|
|
|
sub xdoes {
|
|
$m[$body[$wc-1]] = \&xdodoes; # revector created word to point to dodoes
|
|
$does{$body[$wc-1]} = $ip; # does> code pointer hashed to key "body address"
|
|
$ip = $r[$rp--]; # unnest, preventing execution of does> code now
|
|
}
|
|
primitive "does>", \&xdoes;
|
|
|
|
|
|
# -------- interpreter/compiler -------- #FOLD00
|
|
|
|
# ( a n -- x -1 | d -1 | r -1 | -1 | 0 )
|
|
sub xinterpretnumber {
|
|
xqnumber;
|
|
if ($s[$sp] && $m[$xstate+1]) { # number valid while compiling?
|
|
$dp += 2;
|
|
@m[$dp-2..$dp-1] = ($xlit, $s[--$sp]); # yes: compile number as literal
|
|
$s[$sp] = -1; # and remove from stack.
|
|
}
|
|
}
|
|
my $xinterpretnumber = unnamedprimitive \&xinterpretnumber;
|
|
|
|
|
|
hidden; definitions;
|
|
# ( -- )
|
|
my $xbrinterpret = colon "(interpret)";
|
|
XBEGIN; compile $xbl, $xparse; # pull in string from buffered input
|
|
compile $xdup;
|
|
XWHILE; compile $x2dup, $xlastword, $x2store; # keep copy for literal or error
|
|
compile $xhunt, $xqdup; # got string, look up in dictionary
|
|
XIF; # found in dictionary:
|
|
compile $xdup, $xqimm; # immediate word?
|
|
XIF; compile $xnamefrom, $xexecute; # execute immediate words always
|
|
XELSE; compile $xnamefrom, $xcompiling; # non-immediate words depend on compile state:
|
|
XIF; compile $xcomma; # postponed execution when compiling
|
|
XELSE; compile $xexecute; # immediate execution when interpreting
|
|
XTHEN;
|
|
XTHEN;
|
|
compile $xdepth, $xzeroless; # test for stack underflow
|
|
XIF; compile $xstackunderflow; XTHEN; # throw exception in case of
|
|
XELSE; compile $xlastword, $x2fetch;
|
|
compile $xinterpretnumber, $xzeroequals; # word not found: try as number
|
|
XIF;
|
|
compile $xlastword, $x2fetch, $xnotfound; # neither, try user hook
|
|
XTHEN;
|
|
XTHEN;
|
|
XREPEAT; compile $x2drop;
|
|
semicolon;
|
|
forth; definitions;
|
|
my $xinterpret = defer "interpret", $xbrinterpret;
|
|
|
|
|
|
# ( a n -- )
|
|
my $xevaluate = colon "evaluate";
|
|
compile $xpushsource;
|
|
compile $xinterpret;
|
|
compile $xpopsource;
|
|
semicolon;
|
|
|
|
|
|
# -------- disk I/O --------
|
|
|
|
my $line;
|
|
sub publish {
|
|
if (defined $line) {
|
|
$s[++$sp] = $dp;
|
|
$s[++$sp] = $dp;
|
|
chomp($line);
|
|
unstring $line;
|
|
}
|
|
$s[++$sp] = -(defined $line);
|
|
}
|
|
|
|
# ( a -- u )
|
|
sub xread {
|
|
($line, @disk) = @disk;
|
|
publish;
|
|
}
|
|
my $xread = unnamedprimitive \&xread;
|
|
|
|
|
|
|
|
# ( a n -- )
|
|
sub fileopen {
|
|
open(file1, "< ".string)
|
|
or throw(-38);
|
|
}
|
|
my $xfileopen = primitive "fileopen", \&fileopen;
|
|
|
|
sub fileclose {
|
|
close(file1);
|
|
}
|
|
my $xfileclose = primitive "fileclose", \&fileclose;
|
|
|
|
# ( -- a n -1 | 0 )
|
|
sub fileread {
|
|
$line = <file1>;
|
|
publish;
|
|
}
|
|
my $xfileread = primitive "fileread", \&fileread;
|
|
|
|
|
|
# -------- entry point, init, and VM main loop -------- #FOLD00
|
|
|
|
|
|
my $xprompt = defer "prompt", $xnop;
|
|
my $xquit = defer "quit", $xbye;
|
|
|
|
sub xempty {
|
|
$rp = -1; # init return stack
|
|
$sp = -1; # init data stack
|
|
$catchframe = 0;
|
|
@sourcestack = (); # drop any nested input source
|
|
}
|
|
my $xempty = primitive "empty", \&xempty;
|
|
|
|
my $xabort = colon "abort";
|
|
compile $xquit;
|
|
semicolon;
|
|
|
|
|
|
my $xcold = compile $xonly, $xempty;
|
|
XBEGIN; compile $xread;
|
|
XWHILE; compile $xevaluate;
|
|
XREPEAT;
|
|
my $xwarm = compile $xabort;
|
|
|
|
sub exceptionhandler {
|
|
my $exception = $@;
|
|
my $exceptionnr = $@;
|
|
$exceptionnr =~ s/ .*\n//;
|
|
my $err0 = pack "C*", @m[$parsebuf..$parsebuf+$m[$xtoin+1]-1]; # collect source line from virtual memory
|
|
print "\n", $err0; # print the line containing the error
|
|
$err0 =~ s/ *$//; # strip trailing spaces
|
|
my $all = length($err0); # determine length of whole line
|
|
$err0 =~ s/[^ ]*$//; # strip last space delimited string
|
|
my $ok = length($err0); # determine length of part without error
|
|
print "\n", " " x $ok, "^" x ($all-$ok); # underscore error with carets
|
|
print "\n", $throwmessage{$exceptionnr} if (defined $throwmessage{$exceptionnr});
|
|
print "\nexception ", $exception;
|
|
}
|
|
|
|
|
|
#sub xcolor {
|
|
# my $string = string;
|
|
# print $string;
|
|
# print color($string);
|
|
#}
|
|
#primitive "fg", \&xcolor;
|
|
|
|
sub main {
|
|
$ip = $xcold; # set instruction pointer to coldstart
|
|
until (0) {
|
|
eval {
|
|
until (0) { # virtual machine execution loop:
|
|
$w = $m[$ip++]; # instruction fetch
|
|
# $s[++$sp] = $w; xdotname; xspace;
|
|
# xcr if $w == $xexit;
|
|
$m[$w](); # instruction execute
|
|
}
|
|
}; # interpreter error exit
|
|
exceptionhandler;
|
|
$ip = $xwarm; # reenter at warmstart
|
|
}
|
|
}
|
|
main;
|