# # Pure Data Packet forth word definition file. # Copyright (c) by Tom Schouten # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation# either version 2 of the License, or # (at your option) any later version. # # 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 General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. # # # Packet Forth kernel -- forth side. this file is connected to the # input stream after the C primitives are initialized (see forth.c) # interpreter # TODO: disentangle forth.c so most can be done in forth : <'> read find ; # link structure : xt>name linkhead ; : xt>cta linkhead follow ; : xt>doc linkhead follow follow ; : xt>cfa linkhead follow follow follow ; : xt>ct dup xt>cta @ ; : xt>cf xt>cfa @ ; : docstring xt>doc head @ ; # ( xt -- string ) # this requires the 'doc' location already contans a list : doc! latestxt xt>doc head ! ; "( string -- )\tSet docstring of last defined word." dup doc! : doc doc! ; doc # THREADING MODEL # postpone and friends : postpone, swap [ <'> lit ] literal , , , ; "( ct -- )\tCompile a compilation token." doc : comp' <'> xt>ct ; "( -- ct)\tParses symbol and returns compilation token." doc : postpone comp' postpone, ; immediate "Compiles compilation semantics." doc : ['] <'> postpone literal ; immediate : ]L ] postpone literal ; : pass postpone do-pass ; immediate "Next xt will return to the calling context." doc : route postpone do-route ; immediate "Pass to next xt if equal (no polywords)." doc : forward postpone do-forward ; immediate "Pass to next xt if equal (no polyword). Leave 2nd." doc # compile time semantics : comp! latestxt linkhead follow ! ; "( xt -- )\tSet last word's compilation semantics. (default = ',')" doc : compile xt>ct execute ; : swap! postpone swap postpone ! ; immediate # control flow : if postpone jz here 0 , ; immediate "( condition -- )\tMark conditional jump." doc : then here swap ! ; immediate "End mark conditional jump." doc : else >r postpone jmp here 0 , here r> ! ; immediate "Mark alternative branch." doc : _for postpone >r here ; immediate "( iterations -- ) ( -- counter )R\tMark counted iteration. Balanced by 'next'." doc : _next postpone decrjnz , postpone rdrop ; immediate "( counter -- counter )R\tEnd mark counted iteration. Balances 'for'." doc : begin here ; immediate "Jump target marker. Balanced by 'again' or 'until'." doc : again postpone jmp , ; immediate "Jump to matching 'begin'." doc : until postpone jz , ; immediate "( condition -- )\tJump to matching 'begin' only if condition is false." doc : while postpone jnz , ; immediate "( condition -- )\tJump to matching 'begin' only if condition is true." doc # some saner versions: 0 -> doesnt loop : for postpone dup postpone if postpone _for ; immediate : next postpone _next postpone else postpone drop postpone then ; immediate # some cf compilation words : enter, [ <'> enter xt>cf ]L , ; # ( -- ) : constant, [ <'> doconst xt>cf ]L , , ; # ( value -- ) : buffer, [ <'> dovar xt>cf ]L , ; # ( -- ) : defer, [ <'> dodefer xt>cf ]L , , ; # ( initial.xt -- ) : defer@ xt>body @ ; : defer! xt>body ! ; "( behaviour hook -- )\tSet a deferred word's behaviour." doc # create a new link : link-constant link constant, ; "( value name -- )\tCreate a new link implementing a constant." doc : link-buffer link buffer, ; "( name -- )\tCreate a new link implementing an empty buffer (the non-parsing version of 'create')." doc : link-variable! link buffer, , ; "( value name -- )\tCreate a new link implementing an initalized variable." doc : link-word link enter, ; "( name -- )\tCreate a new link implementing a function (append list of xts)." doc : empty-defer-word e_undef throw ;; : link-defer link ['] empty-defer-word defer, ; "( name -- )\tCreate a new link implementing a deferred word." doc : link-curried link-word swap postpone literal postpone do-pass xt>ct execute ; "( data xt symbol -- )\tCreate a word which performs xt on a copy of data." doc # parsing words : create read link-buffer ; "Parses symbol. Create a new named link with an empty buffer." doc : constant read link-constant ; "( atom -- )\tParses symbol. Creates a constant." doc : variable! read link-variable! ; "( atom -- )\tParses symbol. Creates an initialized variable." doc : variable undef variable! ; "Parses symbol. Creates an uninitialized variable." doc : defer read link-defer ; "Parses symbol. Creates a deferred word. (a hook)." doc # stacks : top head @ ; : bottom tail @ ; # make some words redifinable # after setup.pf is loaded, the kernel updates it's xt cache for some of these <'> , read , link defer, <'> : read : link defer, <'> ; read ; link defer, immediate # compile time parsing : [read] read postpone literal ; immediate # FIXME: these words are obsolete : [s] postpone [read] ; immediate : read ; # create anonymous function # not really anonymous (it is required for code to live in a link) : :noname [read] anonymous link enter, latestxt ] ; "( -- xt )\tDefine an anonymous function." doc : :: :noname ; "( -- xt )\t:noname" doc : <'> defer! ; "( xt -- )\tParses symbol. Set deferred word to xt." doc : [is] <'> postpone literal postpone defer! ; immediate : hole, here undef , ; # compile a patchable hole ( -- hole.addr ) : lit, postpone lit ; # FIXME: get rid of does> since it doesn't fit well in PF threaded code : does> lit, hole, # patched by then postpone install-dodoes # defining word will install dodoes codefield postpone leave # .. and leave postpone then # patch address (does code follows) ; immediate # similar: create a word # embedded code : simpler alternative to doer/make # (see Thinking Forth by Leo Brodie) using xts # something like chained make is not possible here, # but you can use generators for that. : next>xt r> dup @ >r follow >xt ; : { postpone next>xt hole, enter, ; immediate : } postpone leave postpone then ; immediate # macros : @[ postpone dup postpone >r postpone @ ; immediate : ]! postpone r> postpone ! ; immediate # manipulate list on top of rs : >rl postpone rsp postpone push ; immediate "( atom -- )\tPushes an atom to the list in r." doc : rl> postpone rsp postpone pop ; immediate "( -- atom )\tPops an atom from the list in r." doc : >>rl postpone rsp postpone queue ; immediate "( atom -- )\tAdds an atom to the end of the list in r." doc # exceptions : try lit, hole, postpone >r # move it to return stack postpone emarker>r ; immediate # install rewind marker : recover postpone rdrop # normal execution: drop emarker postpone rdrop # drop handler address postpone else ; immediate # patch hole : jmp past endtry : endtry postpone then ; immediate # jump target for successful try # I/O blocking defer block-poll "( -- )\tBlock task, retry on next round." doc defer block-read "( stream -- )\tBlock until stream can be read." doc defer block-write "( stream -- )\tBlock until stream can be written." doc : yield block-poll ;; "( -- )\tBlock task until next scheduler round." doc # OUTPUT defer .S "( -- )\tPrint current data stack." doc defer .R "( -- )\tPrint current return stack." doc <'> debug-stack .S # during bootstrap when I/O is not working # make sure atoms are spaced by sending out newlines. this seems to be # a standard way of doing things in most cases. pf only needs # whitespace, but if there is a separator sent, and the output is not # supposed to be formatted for human readability, using newlines is # the best solution. () variable! stuff : loop-blocking # ( thing count stream ) try begin output-task dup block-write again recover e_eof or-throw drop drop drop drop endtry ; # : loop-blocking output-blocking ; : do-output # ( thing stream XT swap >r # ( thing XT) ( stream )R string dup >r # ( thing XT string ) ( string stream )R swap execute # ( -- ) ( string stream )R r> 0 r> loop-blocking ;; : write-atom0 ['] string-write-atom0 do-output ;; : print-atom ['] string-print-atom do-output ;; : report-atom ['] string-report-atom do-output ;; : write-char >r "%c" string:% r> print-atom ;; : write-atom dup >r write-atom0 # perform write 10 r> write-char ; # terminate with newline "( atom stream -- )\yWrite (unparse) one atom to a stream." doc # output stack currently just contains data values. write/print are # not overridden. if you want to create lists, just use push.. it's # a different semantics anyway. () variable! output-stack : report-current output-stack top report-atom ; : print-current output-stack top print-atom ; : write-current output-stack top write-atom ; : write-current0 output-stack top write-atom0 ; : emit-current output-stack top write-char ; : >output output-stack push ; : drop-output output-stack pop drop ; 1 "" "w" open-fd constant stdout-stream # default is stdout stdout-stream >output : write>stdout stdout-stream write-atom ; : print>stdout stdout-stream print-atom ; : report>stdout stdout-stream report-atom ; : emit>stdout stdout-stream write-char ; defer write defer write0 defer print defer emit defer report # '.' is for convenience : it behaves as report, only it will print # strings, which is basicly what you want for most combined # printing/reporting operations. # space follows the output, so there's no need to do this manually. : . string? if print else report then 32 emit ;; # : . report 32 emit ;; # FIXME: use these when stack is corrupted, so we at least have output. # <'> write>stdout write # <'> print>stdout print <'> write-current write <'> write-current write0 <'> print-current print <'> emit-current emit <'> report-current report # here '.' is working () variable! abort-stack : >abort current-abort @> abort-stack push current-abort ! ; : abort> current-abort @> abort-stack pop current-abort ! ; # abort handlers : abort-drop abort> drop ;; # toplevel handler, execute io-abort once # FIXME: i don't really understand why i should have this, instead of # a default handler in the C code.. # :: "I/O ABORT\n" . undef current-abort ! io-abort ; # <'> io-abort current-abort ! # read handlers (current interpreter input) # we don't have real dynamic closures, so we'll do with these. at any # time, the top of the read-stack contains the current closure data # (usually stream / list / string). the 'read' deferred word # contains the XT that will produce the next item. abort-drop will # return the previous state. # INPUT () variable! input-stack : drop-input input-stack >r r pop drop r> pop drop ; : >input input-stack >r r push r> push ; "( data xt -- )\tMove a code/data pair to the abort stack." doc # the input stack contains: # TOP: the stream/other object # 2ND: the reader XT # this is no longer a deferred word, but takes its meaning from the # contents of the input stack. : read-top@ input-stack head >r r # just pass a reference (avoid copy) r> follow @ execute ; # OLD: # : drop-input input-stack dup pop drop pop [is] read ; # : >input ['] read xt>body @ input-stack push # swap input-stack push # [is] read ; # : current-stream input-stack top ; # : read-current-stream current-stream read-atom ; : sleep sleep-blocking-start try begin sleep-blocking-task # will throw e_eof when done block-poll # no events, just reschedule again recover e_eof or-throw drop drop drop endtry ; # the default scheduler just sleeps for 10 ms, so until scheduler.pf # is loaded, PF runs single threaded, and blocks on I/O, yielding to the # OS by sleeping. :: drop block-microsleep ; dup block-read block-write <'> block-microsleep block-poll # blocking loop ( stream state -- stream state atom ) : read-loop read-task dup undef scalar:= if drop over block-read pass read-loop then ; : read-thing read-loop >r drop drop r> ; : read-atom () read-thing ;; : read-atom-debug read-atom dup . ; # connect a stream to the input : @read-atom @ read-atom ; : stream>input ['] @read-atom >input ; # switch readers: until now the bootstrap reader 'boot-read' connected # to this file was active', here we do the magic trick of switching it # to the input-stack system, by snatching the stream from the code. # see forth.c : setup_interpreter() <'> boot-read xt>body follow @ stream>input <'> read-top@ read # maybe also discard execution context, so we're the only thing # running? # () swapreturn drop # at this point we have most of the core functionality and # will put the rest in other files. the word below is a temporary loader # the word 'load' will be defined in stream.pf once the polywords are there. # so load does: # - save 'read' word # - open stream # - set new 'read' semantics # - close stream # - restore 'read' word # FIXME: unimplemented words # : NI "\n" . . " NOT IMPLEMENTED\n" . ; # : .task @ . ".task" NI ; : load homedir "/script/" string:concat swap string:concat # build path "r" open-file stream>input # open the file begin try read recover # need to catch e_eof dup e_eof scalar:= int:not if throw then # not e_eof -> rethrow drop drop-input leave # else cleanup (only valid exit is here) endtry interpret # won't catch error here to do cleanup: error in kernel file == fatal again ; # load some other modules "error.pf" load # error reporting "poly.pf" load # support for polymorphic words "misc.pf" load # misc utility stuff "intcomp.pf" load # interpret / compile words "counter.pf" load # counter object "list.pf" load # list processing "printing.pf" load # misc printing "stream.pf" load # stream support "hooks.pf" load # event chains # "/tmp/crash.pf" loadscript "dictionary.pf" load # dictionary related things "modules.pf" load # load- style words for optional things "help.pf" load # documentation "batch.pf" load # batch mode operation : version "version.pf" load . cr ; # "broembroem" . # "END: setup.pf\n" . # load user .pfrc : pfrc "HOME" getenv "/.pfrc" concat dup exists? if load else drop then ; pfrc # handle arguments args pop variable! program-name # in case anyone is interested : check-interactive args head null? if interactive then ; : check-stdin args top "-" = if stdin then ; : check-debug args top "debug" = if debug then ; # check-puredata check-interactive check-stdin check-debug # run payload args top load # reached after script returns 0 pf-exit-now