Merthese interpreter (SysRPL) v0.00.00

%%HP: T(3)A(R)F(.);
DIR
  MAKE
  \<< 2. TVARS 1.
    \<<
      IF DUP \->STR DUP SIZE DUP
4. - SWAP SUB ".SRC'" ==
      THEN DUP \->STR DUP SIZE 5.
- 2. SWAP SUB DUP 1. DISP S~N
SWAP RCL ASM SWAP STO
      ELSE DROP
      END
    \>> DOLIST
  \>>
  $TITLE
"Merthese interpreter (SysRPL)
Travis Evans
v0.00.00  2012/01/05"
  $ROMID 865.
  $VISIBLE { MERTHESE
MERTHESEMOD ASHBAD.MOD TEV.MOD
NIKKY.MOD KERM.MOD LOADMODULE
ADDCOMMAND EXECCMD APPENDOUTPUT
GETRANDCHAR GETRANDCOMP }
  $HIDDEN { MERTHESE.MOD
INITMODULES RANDINT LOOPRAND
LOOPN }
  $CONFIG 0.
  ASHBAD.MOD.SRC
"(Merthing and Ashbad are awesome
 module)
::
  \\"a\\"
  \\"ASHBAD IZ SMRT\\"
  ID ADDCOMMAND
;
@"
  TEV.MOD.SRC
"(Merthing && tev module)
::
  (t: Print incrementing seq of
   chars of rand len 0-13
   starting from accum. char.
   Set accum. to final char+1
   50% of the time)
  \\"t\\"
  ' ::
    NULL$
    LAM \<-accum
    ' ::
      DUP DOCHR SWAP %1+
      UNROT  ID APPENDOUTPUT
      SWAP
    ;
    ZERO THIRTEEN
    ID LOOPRAND
    {
     :: ' LAM \<-accum  STOLAM ;
     :: DROP ;
    }
    ID GETRANDCOMP  EVAL
  ;
  ID ADDCOMMAND

  (e: Print one of .,;:-!? )
  \\"e\\"
  ' ::
    \\".,;:-!?\\"  ID GETRANDCHAR
  ;
  ID ADDCOMMAND

  (v: Print accum. char ROT13'ed)
  \\"v\\"
  ' ::
    \\"abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\\"
    LAM \<-accum  DOCHR  ONE  POS$
    DUP#0=case
    :: DROP  LAM \<-accum  DOCHR ;
    \\"nopqrstuvwxyzabcdefghijklmNOPQRSTUVWXYZABCDEFGHIJKLM\\"
    SWAPDUP SUB$
  ;
  ID ADDCOMMAND
;
@"
  NIKKY.MOD.SRC
"(Merthing w/ Nikky module)
::
  (n: Add following char in input
   stream to accum.)
  \\"n\\"
  ' ::
    LAM \<-in  LAM inpos#  #1+  DUP
    SUB$  xNUM  LAM \<-accum  %+
    ' LAM \<-accum  STOLAM
    (Skip past just-used char)
    LAM inpos#  #1+
    ' LAM inpos#  STOLAM
    NULL$
  ;
  ID ADDCOMMAND

  (i: Input char for accum.)
  \\"i\\"
  ' ::
    \\"Character, please!\\" NULL$
    ONE ZEROZEROZERO FALSE ZERO
    TRUE ZERO InputLine
    ?SKIP ABORT
    xNUM  ' LAM \<-accum  STOLAM
    NULL$
  ;
  ID ADDCOMMAND

  (k: Print \\"nikky\\")
  \\"k\\"
  \\"nikky\\"
  ID ADDCOMMAND

  (y: Loop: Number of times
   indicated by next char in
   stream; character after next
   char will be executed this
   many times)
  \\"y\\"
  ' ::
    (Watch for [ON] abort, in
     case someone unwittingly
     runs something like
     \\"yyyyyyyy...\\" :P )
    ?ATTNQUIT

    (Save pos of looped cmd to
     execute)
    LAM inpos#  #2+
    DUP  ' LAM inpos#  STOLAM
    SWAP

    (Code to loop--restore prog
     pos ptr then execute cmd)
    ' ::
      OVER  ' LAM inpos#  STOLAM
      ID EXECCMD
    ;

    LAM \<-in  4PICK  #1-
    DUP SUB$ xNUM COERCE
    ID LOOPN

    (Set pos to end of now-
     completed loop[s])

    SWAP  ( pos out$ \-> out$ pos )
    BEGIN
      LAM \<-in  OVERDUP  SUB$
      \\"y\\" EQUAL
    WHILE #2+ REPEAT
    ' LAM inpos#  STOLAM

    NULL$
  ;
  ID ADDCOMMAND
;
@"
  KERM.MOD.SRC
"(Merthing @ Kerm module)
::
  (k: Print accum. char)
  \\"k\\"
  ' :: LAM \<-accum  DOCHR ;
  ID ADDCOMMAND

  (e: Increment accum.)
  \\"e\\"
  ' ::
    LAM \<-accum  %1+
    ' LAM \<-accum  STOLAM
    NULL$
  ;
  ID ADDCOMMAND

  (r: Reset accum.)
  \\"r\\"
  ' ::
    %0  ' LAM \<-accum  STOLAM
    NULL$
  ;
  ID ADDCOMMAND

  (m: Print accum. as decimal)
  \\"m\\"
  ' ::
    (Conv to ZINT to remove
     annoying trailing period)
    LAM \<-accum  %IP  FPTR2 ^R>Z
    FPTR2 ^Z>S
  ;
  ID ADDCOMMAND
;
@"
  MERTHESE.MOD.SRC
"(Internal Merthese base module)
::
  (m: Print \\"merth\\")
  \\"m\\"
  \\"merth\\"
  ID ADDCOMMAND

  (e: Print newline)
  \\"e\\"
  NEWLINE$
  ID ADDCOMMAND

  (r: Print space)
  \\"r\\"
  SPACE$
  ID ADDCOMMAND

  (t: Print string of random
   chars a-z with random length
   0-13)
  \\"t\\"
  ' ::
    ' ::
      \\"abcdefghijklmnopqrstuvwxyz\\"
      ID GETRANDCHAR
      ID APPENDOUTPUT
    ;
    ZERO THIRTEEN
    ID LOOPRAND
    NULL$
  ;
  ID ADDCOMMAND

  (h: Seek to next 'h' char and
   resume execution from there)
  \\"h\\"
  ' ::
    LAM \<-in  \\"h\\"  LAM inpos#  #1+
    POS$
    (If not found, zero will be
     saved as prog pos, signaling
     execution to immediately
     end.)
    ' LAM inpos#  STOLAM
    NULL$  (No string output)
  ;
  ID ADDCOMMAND

  (Easter egg :]  Evidently,
   someone was getting a little
   too bored while coding :P )
  NULL$
  \\"A null string?
Are you kidding me?
AHAHAHAHAHAHAHAHAHAHAHA!\\"
  ID ADDCOMMAND
;
@"
  MERTHESE.SRC
"( mertheseprog$ \->
 Runs a Merthese program.
 Extension modules to be used can
 be named in global list
 'MertheseModules'.
)
::
  CK1&Dispatch
  THREE  (Str)
  ::
    ' ID MertheseModules  @
    ITE
    ::
      DUPTYPELIST? ?SEMI
      DROP NULL{}
    ;
    ::
      NULL{} DUP
      ' ID MertheseModules
      STO
    ;
    ID MERTHESEMOD
  ;
;
@"
  MERTHESEMOD.SRC
"( prog$ modulelist \-> output$
 Interprets Merthese program
 prog$ using any optional
 extension modules named in
 modulelist.
)
::
  CK2&Dispatch
  STRLIST
  ::
    (Set up shared vars [may be
     read and manipulated by
     User/SysRPL extension
     modules])
    ZERO DUP UNCOERCE DUP { } %0
    {
      LAM \<-in       (Input prog str)
      LAM \<-modules  (List of modules)
      LAM inpos#    (Curr prog pos, BINT)
      LAM \<-inpos    (Curr prog pos, real [for UserRPL modules])
      LAM lastinpos (Bkup of \<-inpos to test for modification)
      LAM \<-cmds     (Merthese char lookup table)
      LAM \<-accum    (Accumulator character, real)
    }
    BIND
      LAM \<-modules
      ID INITMODULES

      (Main interpreter loop)
      NULL$  (Output string)
      BEGIN
        (Check for [ON] break)
        ?ATTNQUIT

        (Advance inpos)
        LAM inpos#  #1+DUP
        UNCOERCE DUP
        ' LAM \<-inpos  STOLAM
        ' LAM lastinpos  STOLAM
        ' LAM inpos#  STOLAM

        (Execute next
         instruction and append
         output)
        ID EXECCMD

        (Adjust inpos# if \<-inpos
         changed)
        LAM \<-inpos  DUP
        LAM lastinpos
        %<>  ITE
        ::
          DUP COERCE
          ' LAM inpos#  STOLAM
          DUP
          ' LAM \<-inpos  STOLAM
          ' LAM lastinpos  STOLAM
        ;
        DROP

        (Stop once interpreter
         ptr is 0 or is beyond
         end of input prog)
        LAM inpos#  DUP  #0=
        SWAP  LAM \<-in  LEN$  #>=_
        OR
      UNTIL
    ABND
  ;
;
@"
  INITMODULES.SRC
"( modulelist \->
 Sets up extension modules named
 in modulelist.
)
::
  (Load base Merthese module)
  ' ID MERTHESE.MOD
  ID LOADMODULE

  (Load remaining modules in
   specified order)
  INNERCOMP reversym
  ' ID LOADMODULE
  SWAP
  ID LOOPN
;
@"
  LOADMODULE.SRC
"( module \->
 Load a Merthese module
)
::
  CK1&Dispatch
  SIX  (Global name)
  ::
    ?ATTNQUIT
    xRCL  COLA  ID LOADMODULE
  ;
  SEVEN  (Local name)
  ::
    ?ATTNQUIT
    xRCL  COLA  ID LOADMODULE
  ;
  FIFTEEN  (ROMPTR)
  EVAL
  EIGHT  (Program)
  EVAL
;
@"
  ADDCOMMAND.SRC
"( char$ action \->
 Adds a Merthese command.  char$
 in a Merthese program will eval
 obj 'action'.
)
::
  CK2&Dispatch
  #30 (str, obj)
  ::
    {{ action char$ }}

    (Add command action to lookup
     list)
    char$  ' EQUAL  LAM \<-cmds
    Lookup case
    ::
      (Insert additional action
       for char)
      action >HCOMP
      LAM \<-cmds  char$
      EQUALPOSCOMP #1+
      LAM \<-cmds  PUTLIST
      ' LAM \<-cmds  STOLAM
    ;
    (Add new char & action)
    LAM \<-cmds SWAP
      action ONE {}N
    TWO {}N
    &COMP
    ' LAM \<-cmds  STOLAM
  ;
  #6F0 (char, obj)
  ::
    (Convert chr to str; restart)
    SWAP CHR>$ SWAP
    ID ADDCOMMAND
  ;
;
@"
  EXECCMD.SRC
"( str \-> str'
 Dispatch and execute Merthese
 command at current prog pos;
 append output to given str
)
::
  CK1&Dispatch
  THREE  (str)
  ::
    LAM \<-in  LAM inpos#  DUP  SUB$
    ' EQUAL  LAM \<-cmds
    Lookup NOTcase DROP  (Ignore unknown chars)
    ID GETRANDCOMP  EVAL
    ID APPENDOUTPUT
  ;
;
@"
  APPENDOUTPUT.SRC
"( obj obj \-> str
 Make sure stack has two objects,
 convert them to strings if
 necessary, then concatenate
 them
)
::
  CK2
  DO>STR SWAP DO>STR SWAP &$
;
@"
  GETRANDCHAR.SRC
"( str \-> str'
 Return a randomly-selected
 char from a string [returned as
 a 1-char str, not a system
 char!]
)
::
  CK1&Dispatch
  THREE  (str)
  ::
    DUPLEN$ ONESWAP
    ID RANDINT
    DUP SUB$
  ;
;
@"
  GETRANDCOMP.SRC
"( comp \-> obj
 Return a randomly-selected
 obj from a composite
)
::
  CK1&Dispatch
  FIVE  (list)
  ::
    DUPLENCOMP ONESWAP
    ID RANDINT
    NTHELCOMP DROP
  ;
;
@"
  RANDINT.SRC
"( #min #max \-> #
 Return random bint from #min to
 #max
)
::
  OVER #- UNCOERCE %RAN %*
  SWAP UNCOERCE %+ COERCE
;
@"
  LOOPN.SRC
"( obj #numloops \->
 Eval 'obj' '#numloops' times
)
::
  (Do nothing if zero loops)
  DUP #0=case 2DROP

  SWAP
  { LAM obj } BIND
  ZERO_DO
    LAM obj  EVAL
  LOOP
  ABND
;
@"
  LOOPRAND.SRC
"( obj #min #max \->
 Eval obj random # of times from
 #min to #max
)
::
  ID RANDINT
  ID LOOPN
;
@"
END