Advertisement
tev

Merthese interpreter (SysRPL) v0.00.00

tev
Jan 6th, 2012
67
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 9.39 KB | None | 0 0
  1. %%HP: T(3)A(R)F(.);
  2. DIR
  3. MAKE
  4. \<< 2. TVARS 1.
  5. \<<
  6. IF DUP \->STR DUP SIZE DUP
  7. 4. - SWAP SUB ".SRC'" ==
  8. THEN DUP \->STR DUP SIZE 5.
  9. - 2. SWAP SUB DUP 1. DISP S~N
  10. SWAP RCL ASM SWAP STO
  11. ELSE DROP
  12. END
  13. \>> DOLIST
  14. \>>
  15. $TITLE
  16. "Merthese interpreter (SysRPL)
  17. Travis Evans
  18. v0.00.00 2012/01/05"
  19. $ROMID 865.
  20. $VISIBLE { MERTHESE
  21. MERTHESEMOD ASHBAD.MOD TEV.MOD
  22. NIKKY.MOD KERM.MOD LOADMODULE
  23. ADDCOMMAND EXECCMD APPENDOUTPUT
  24. GETRANDCHAR GETRANDCOMP }
  25. $HIDDEN { MERTHESE.MOD
  26. INITMODULES RANDINT LOOPRAND
  27. LOOPN }
  28. $CONFIG 0.
  29. ASHBAD.MOD.SRC
  30. "(Merthing and Ashbad are awesome
  31. module)
  32. ::
  33. \\"a\\"
  34. \\"ASHBAD IZ SMRT\\"
  35. ID ADDCOMMAND
  36. ;
  37. @"
  38. TEV.MOD.SRC
  39. "(Merthing && tev module)
  40. ::
  41. (t: Print incrementing seq of
  42. chars of rand len 0-13
  43. starting from accum. char.
  44. Set accum. to final char+1
  45. 50% of the time)
  46. \\"t\\"
  47. ' ::
  48. NULL$
  49. LAM \<-accum
  50. ' ::
  51. DUP DOCHR SWAP %1+
  52. UNROT ID APPENDOUTPUT
  53. SWAP
  54. ;
  55. ZERO THIRTEEN
  56. ID LOOPRAND
  57. {
  58. :: ' LAM \<-accum STOLAM ;
  59. :: DROP ;
  60. }
  61. ID GETRANDCOMP EVAL
  62. ;
  63. ID ADDCOMMAND
  64.  
  65. (e: Print one of .,;:-!? )
  66. \\"e\\"
  67. ' ::
  68. \\".,;:-!?\\" ID GETRANDCHAR
  69. ;
  70. ID ADDCOMMAND
  71.  
  72. (v: Print accum. char ROT13'ed)
  73. \\"v\\"
  74. ' ::
  75. \\"abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\\"
  76. LAM \<-accum DOCHR ONE POS$
  77. DUP#0=case
  78. :: DROP LAM \<-accum DOCHR ;
  79. \\"nopqrstuvwxyzabcdefghijklmNOPQRSTUVWXYZABCDEFGHIJKLM\\"
  80. SWAPDUP SUB$
  81. ;
  82. ID ADDCOMMAND
  83. ;
  84. @"
  85. NIKKY.MOD.SRC
  86. "(Merthing w/ Nikky module)
  87. ::
  88. (n: Add following char in input
  89. stream to accum.)
  90. \\"n\\"
  91. ' ::
  92. LAM \<-in LAM inpos# #1+ DUP
  93. SUB$ xNUM LAM \<-accum %+
  94. ' LAM \<-accum STOLAM
  95. (Skip past just-used char)
  96. LAM inpos# #1+
  97. ' LAM inpos# STOLAM
  98. NULL$
  99. ;
  100. ID ADDCOMMAND
  101.  
  102. (i: Input char for accum.)
  103. \\"i\\"
  104. ' ::
  105. \\"Character, please!\\" NULL$
  106. ONE ZEROZEROZERO FALSE ZERO
  107. TRUE ZERO InputLine
  108. ?SKIP ABORT
  109. xNUM ' LAM \<-accum STOLAM
  110. NULL$
  111. ;
  112. ID ADDCOMMAND
  113.  
  114. (k: Print \\"nikky\\")
  115. \\"k\\"
  116. \\"nikky\\"
  117. ID ADDCOMMAND
  118.  
  119. (y: Loop: Number of times
  120. indicated by next char in
  121. stream; character after next
  122. char will be executed this
  123. many times)
  124. \\"y\\"
  125. ' ::
  126. (Watch for [ON] abort, in
  127. case someone unwittingly
  128. runs something like
  129. \\"yyyyyyyy...\\" :P )
  130. ?ATTNQUIT
  131.  
  132. (Save pos of looped cmd to
  133. execute)
  134. LAM inpos# #2+
  135. DUP ' LAM inpos# STOLAM
  136. SWAP
  137.  
  138. (Code to loop--restore prog
  139. pos ptr then execute cmd)
  140. ' ::
  141. OVER ' LAM inpos# STOLAM
  142. ID EXECCMD
  143. ;
  144.  
  145. LAM \<-in 4PICK #1-
  146. DUP SUB$ xNUM COERCE
  147. ID LOOPN
  148.  
  149. (Set pos to end of now-
  150. completed loop[s])
  151.  
  152. SWAP ( pos out$ \-> out$ pos )
  153. BEGIN
  154. LAM \<-in OVERDUP SUB$
  155. \\"y\\" EQUAL
  156. WHILE #2+ REPEAT
  157. ' LAM inpos# STOLAM
  158.  
  159. NULL$
  160. ;
  161. ID ADDCOMMAND
  162. ;
  163. @"
  164. KERM.MOD.SRC
  165. "(Merthing @ Kerm module)
  166. ::
  167. (k: Print accum. char)
  168. \\"k\\"
  169. ' :: LAM \<-accum DOCHR ;
  170. ID ADDCOMMAND
  171.  
  172. (e: Increment accum.)
  173. \\"e\\"
  174. ' ::
  175. LAM \<-accum %1+
  176. ' LAM \<-accum STOLAM
  177. NULL$
  178. ;
  179. ID ADDCOMMAND
  180.  
  181. (r: Reset accum.)
  182. \\"r\\"
  183. ' ::
  184. %0 ' LAM \<-accum STOLAM
  185. NULL$
  186. ;
  187. ID ADDCOMMAND
  188.  
  189. (m: Print accum. as decimal)
  190. \\"m\\"
  191. ' ::
  192. (Conv to ZINT to remove
  193. annoying trailing period)
  194. LAM \<-accum %IP FPTR2 ^R>Z
  195. FPTR2 ^Z>S
  196. ;
  197. ID ADDCOMMAND
  198. ;
  199. @"
  200. MERTHESE.MOD.SRC
  201. "(Internal Merthese base module)
  202. ::
  203. (m: Print \\"merth\\")
  204. \\"m\\"
  205. \\"merth\\"
  206. ID ADDCOMMAND
  207.  
  208. (e: Print newline)
  209. \\"e\\"
  210. NEWLINE$
  211. ID ADDCOMMAND
  212.  
  213. (r: Print space)
  214. \\"r\\"
  215. SPACE$
  216. ID ADDCOMMAND
  217.  
  218. (t: Print string of random
  219. chars a-z with random length
  220. 0-13)
  221. \\"t\\"
  222. ' ::
  223. ' ::
  224. \\"abcdefghijklmnopqrstuvwxyz\\"
  225. ID GETRANDCHAR
  226. ID APPENDOUTPUT
  227. ;
  228. ZERO THIRTEEN
  229. ID LOOPRAND
  230. NULL$
  231. ;
  232. ID ADDCOMMAND
  233.  
  234. (h: Seek to next 'h' char and
  235. resume execution from there)
  236. \\"h\\"
  237. ' ::
  238. LAM \<-in \\"h\\" LAM inpos# #1+
  239. POS$
  240. (If not found, zero will be
  241. saved as prog pos, signaling
  242. execution to immediately
  243. end.)
  244. ' LAM inpos# STOLAM
  245. NULL$ (No string output)
  246. ;
  247. ID ADDCOMMAND
  248.  
  249. (Easter egg :] Evidently,
  250. someone was getting a little
  251. too bored while coding :P )
  252. NULL$
  253. \\"A null string?
  254. Are you kidding me?
  255. AHAHAHAHAHAHAHAHAHAHAHA!\\"
  256. ID ADDCOMMAND
  257. ;
  258. @"
  259. MERTHESE.SRC
  260. "( mertheseprog$ \->
  261. Runs a Merthese program.
  262. Extension modules to be used can
  263. be named in global list
  264. 'MertheseModules'.
  265. )
  266. ::
  267. CK1&Dispatch
  268. THREE (Str)
  269. ::
  270. ' ID MertheseModules @
  271. ITE
  272. ::
  273. DUPTYPELIST? ?SEMI
  274. DROP NULL{}
  275. ;
  276. ::
  277. NULL{} DUP
  278. ' ID MertheseModules
  279. STO
  280. ;
  281. ID MERTHESEMOD
  282. ;
  283. ;
  284. @"
  285. MERTHESEMOD.SRC
  286. "( prog$ modulelist \-> output$
  287. Interprets Merthese program
  288. prog$ using any optional
  289. extension modules named in
  290. modulelist.
  291. )
  292. ::
  293. CK2&Dispatch
  294. STRLIST
  295. ::
  296. (Set up shared vars [may be
  297. read and manipulated by
  298. User/SysRPL extension
  299. modules])
  300. ZERO DUP UNCOERCE DUP { } %0
  301. {
  302. LAM \<-in (Input prog str)
  303. LAM \<-modules (List of modules)
  304. LAM inpos# (Curr prog pos, BINT)
  305. LAM \<-inpos (Curr prog pos, real [for UserRPL modules])
  306. LAM lastinpos (Bkup of \<-inpos to test for modification)
  307. LAM \<-cmds (Merthese char lookup table)
  308. LAM \<-accum (Accumulator character, real)
  309. }
  310. BIND
  311. LAM \<-modules
  312. ID INITMODULES
  313.  
  314. (Main interpreter loop)
  315. NULL$ (Output string)
  316. BEGIN
  317. (Check for [ON] break)
  318. ?ATTNQUIT
  319.  
  320. (Advance inpos)
  321. LAM inpos# #1+DUP
  322. UNCOERCE DUP
  323. ' LAM \<-inpos STOLAM
  324. ' LAM lastinpos STOLAM
  325. ' LAM inpos# STOLAM
  326.  
  327. (Execute next
  328. instruction and append
  329. output)
  330. ID EXECCMD
  331.  
  332. (Adjust inpos# if \<-inpos
  333. changed)
  334. LAM \<-inpos DUP
  335. LAM lastinpos
  336. %<> ITE
  337. ::
  338. DUP COERCE
  339. ' LAM inpos# STOLAM
  340. DUP
  341. ' LAM \<-inpos STOLAM
  342. ' LAM lastinpos STOLAM
  343. ;
  344. DROP
  345.  
  346. (Stop once interpreter
  347. ptr is 0 or is beyond
  348. end of input prog)
  349. LAM inpos# DUP #0=
  350. SWAP LAM \<-in LEN$ #>=_
  351. OR
  352. UNTIL
  353. ABND
  354. ;
  355. ;
  356. @"
  357. INITMODULES.SRC
  358. "( modulelist \->
  359. Sets up extension modules named
  360. in modulelist.
  361. )
  362. ::
  363. (Load base Merthese module)
  364. ' ID MERTHESE.MOD
  365. ID LOADMODULE
  366.  
  367. (Load remaining modules in
  368. specified order)
  369. INNERCOMP reversym
  370. ' ID LOADMODULE
  371. SWAP
  372. ID LOOPN
  373. ;
  374. @"
  375. LOADMODULE.SRC
  376. "( module \->
  377. Load a Merthese module
  378. )
  379. ::
  380. CK1&Dispatch
  381. SIX (Global name)
  382. ::
  383. ?ATTNQUIT
  384. xRCL COLA ID LOADMODULE
  385. ;
  386. SEVEN (Local name)
  387. ::
  388. ?ATTNQUIT
  389. xRCL COLA ID LOADMODULE
  390. ;
  391. FIFTEEN (ROMPTR)
  392. EVAL
  393. EIGHT (Program)
  394. EVAL
  395. ;
  396. @"
  397. ADDCOMMAND.SRC
  398. "( char$ action \->
  399. Adds a Merthese command. char$
  400. in a Merthese program will eval
  401. obj 'action'.
  402. )
  403. ::
  404. CK2&Dispatch
  405. #30 (str, obj)
  406. ::
  407. {{ action char$ }}
  408.  
  409. (Add command action to lookup
  410. list)
  411. char$ ' EQUAL LAM \<-cmds
  412. Lookup case
  413. ::
  414. (Insert additional action
  415. for char)
  416. action >HCOMP
  417. LAM \<-cmds char$
  418. EQUALPOSCOMP #1+
  419. LAM \<-cmds PUTLIST
  420. ' LAM \<-cmds STOLAM
  421. ;
  422. (Add new char & action)
  423. LAM \<-cmds SWAP
  424. action ONE {}N
  425. TWO {}N
  426. &COMP
  427. ' LAM \<-cmds STOLAM
  428. ;
  429. #6F0 (char, obj)
  430. ::
  431. (Convert chr to str; restart)
  432. SWAP CHR>$ SWAP
  433. ID ADDCOMMAND
  434. ;
  435. ;
  436. @"
  437. EXECCMD.SRC
  438. "( str \-> str'
  439. Dispatch and execute Merthese
  440. command at current prog pos;
  441. append output to given str
  442. )
  443. ::
  444. CK1&Dispatch
  445. THREE (str)
  446. ::
  447. LAM \<-in LAM inpos# DUP SUB$
  448. ' EQUAL LAM \<-cmds
  449. Lookup NOTcase DROP (Ignore unknown chars)
  450. ID GETRANDCOMP EVAL
  451. ID APPENDOUTPUT
  452. ;
  453. ;
  454. @"
  455. APPENDOUTPUT.SRC
  456. "( obj obj \-> str
  457. Make sure stack has two objects,
  458. convert them to strings if
  459. necessary, then concatenate
  460. them
  461. )
  462. ::
  463. CK2
  464. DO>STR SWAP DO>STR SWAP &$
  465. ;
  466. @"
  467. GETRANDCHAR.SRC
  468. "( str \-> str'
  469. Return a randomly-selected
  470. char from a string [returned as
  471. a 1-char str, not a system
  472. char!]
  473. )
  474. ::
  475. CK1&Dispatch
  476. THREE (str)
  477. ::
  478. DUPLEN$ ONESWAP
  479. ID RANDINT
  480. DUP SUB$
  481. ;
  482. ;
  483. @"
  484. GETRANDCOMP.SRC
  485. "( comp \-> obj
  486. Return a randomly-selected
  487. obj from a composite
  488. )
  489. ::
  490. CK1&Dispatch
  491. FIVE (list)
  492. ::
  493. DUPLENCOMP ONESWAP
  494. ID RANDINT
  495. NTHELCOMP DROP
  496. ;
  497. ;
  498. @"
  499. RANDINT.SRC
  500. "( #min #max \-> #
  501. Return random bint from #min to
  502. #max
  503. )
  504. ::
  505. OVER #- UNCOERCE %RAN %*
  506. SWAP UNCOERCE %+ COERCE
  507. ;
  508. @"
  509. LOOPN.SRC
  510. "( obj #numloops \->
  511. Eval 'obj' '#numloops' times
  512. )
  513. ::
  514. (Do nothing if zero loops)
  515. DUP #0=case 2DROP
  516.  
  517. SWAP
  518. { LAM obj } BIND
  519. ZERO_DO
  520. LAM obj EVAL
  521. LOOP
  522. ABND
  523. ;
  524. @"
  525. LOOPRAND.SRC
  526. "( obj #min #max \->
  527. Eval obj random # of times from
  528. #min to #max
  529. )
  530. ::
  531. ID RANDINT
  532. ID LOOPN
  533. ;
  534. @"
  535. END
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement