home *** CD-ROM | disk | FTP | other *** search
/ NetNews Usenet Archive 1992 #26 / NN_1992_26.iso / spool / comp / lang / perl / 6872 < prev    next >
Encoding:
Text File  |  1992-11-07  |  29.8 KB  |  1,084 lines
  1. Newsgroups: comp.lang.perl
  2. Path: sparky!uunet!decwrl!netcomsv!netcom.com!jeffrey
  3. From: jeffrey@netcom.com (Jeffrey Kegler)
  4. Subject: Marpa, prototype of a Hacker's Parser for Perl
  5. Message-ID: <1992Nov6.120224.12846@netcom.com>
  6. Sender: jeffrey@algor2.algorists.com
  7. Organization: Algorists, Inc.
  8. Date: Fri, 6 Nov 1992 12:02:24 GMT
  9. Lines: 1073
  10.  
  11. Following my signature is a shar archive of the working prototype of
  12. the Marpa parser.  Marpa is the name of the parse engine itself --
  13. it's a library of perl routines.  Milarepa is a program which uses a
  14. subset of Marpa's capabilities to take a file of BNF and associated
  15. actions (in Perl!), and parse them into a Perl program which parses
  16. its input standard, performing the actions.  Both milarepa.pl and the
  17. Perl program it writes on its standard output use Marpa.  milarepa.pl
  18. both produces examples of Marpa usage, and is itself a moderately
  19. sophisticated one.
  20.  
  21. For example, test2.mr describes a calculator in the Milarepa language,
  22. a straightforward combination of BNF and Perl.  Running the command
  23. "perl milarepa.pl < test2.mr > testmr2.pl" creates the calculator, and
  24. "perl testmr2.pl" runs it.  The example just adds and multiplies but a
  25. glance at test2.mr should show how easily it could be extended into a
  26. very powerful calculator.
  27.  
  28. The files in the package are
  29.  
  30. marpa.pl    -- the heart of the Marpa prototype, its parsing routines
  31. milarepa.pl -- creates simple Marpa compilers or interpreters
  32.                 from BNF and Perl
  33. test.mr     -- the Milarepa code for an arithmetic expression compiler
  34. mrtest.pl   -- The above compiler compiled into a Perl script which
  35.                prints the parse for simple arithmetic expressions
  36. test2.mr    -- the Milarepa code for an arithmetic expression interpreter
  37. mrtest2.pl  -- The above interpreter compiled into a perl script which
  38.         evaluates simple arithmetic expressions
  39. tilopa.pl   -- A simple lexer used by Milarepa
  40. naropa.pl   -- Other simple routines used by Milarepa 
  41. test.pl     -- A simple program using Marpa
  42. test2.pl    -- Another simple program using Marpa
  43.  
  44. This is intended to be a real hacker's parser.  It is not restricted
  45. to LR(k), and the parse logic follows directly from the BNF.  It
  46. handles ambiguous grammars, ambiguous tokens (tokens which were not
  47. positively identified by the lexer) and allows the programmer to
  48. change the start symbol.  There is no fixed distinction between
  49. terminals and non-terminals, that is, a symbol can both match the
  50. input AND be on the left hand side of a production.  Multiple Marpa
  51. grammars are allowed in a single perl program.  The grammar is
  52. extensible.  The BNF may have productions added (or, as an extension,
  53. deleted) after parsing has begun.
  54.  
  55. Since, unlike LR parsers, Marpa's logic follows directly from the BNF,
  56. hackers should be able to invent tricks.  For example, the order in
  57. which productions are tested is controlled by the programmer.  He can
  58. perform error handling by inserting special error productions into the
  59. grammar, which detect those cases he wishes to report ("Missing comma
  60. in list", etc.).  These productions can come after the others, so that
  61. no input ever fails to parse in the strict sense, some merely return
  62. special "error parses" which indicate the problem.  It does not bother
  63. Marpa if the new productions introduce ambiguities into the grammar.
  64.  
  65. Of course, I happily offer Marpa under the same terms of free
  66. redistributability that I was offered perl.
  67.  
  68. There are two restrictions on the grammar, neither of which I believe
  69. will prevent Marpa from handling any grammar of practical use.  First,
  70. the grammar may not be left recursive.  Left recursion makes Marpa
  71. recurse infinitely.  A later version will detect left recursion and
  72. stop the parse with an error.
  73.  
  74. Second, the input must be divided into sentences of a finite maximum
  75. length.  This restriction is unusual in parsing theory, but is easy to
  76. apply to any grammar of practical interest.  A language where the
  77. parseable entities ran many pages would not be readable or writable by
  78. humans, and even the most obscure computer languages must be divided
  79. into pieces by the human being reading them, otherwise they would not
  80. be comprehensible at all.
  81.  
  82. With this restriction, Marpa runs very fast.  I have done a C language
  83. prototype of Marpa, and it chomps down large, highly ambiguous
  84. sentences of an English subset rapidly.  The theoretical speed, with
  85. division into sentences of maximum fixed length, is linear, or O(n).
  86. The C code works by pushing pointers onto and off of stacks, and runs
  87. very fast.
  88.  
  89. This implementation is not fast, since it prototypes Marpa in Perl.  I
  90. am now seeking help in converting Marpa into part of Perl.
  91.  
  92. Any parser needs help in lexing, and in evaluating the semantics of
  93. the results.  Perl's power in these areas makes it an ideal place to
  94. embed Marpa.
  95.  
  96. The current documentation stinks.  It forms the rest of this message.
  97.  
  98. This interface didn't come out very "perl-ish", and that may be due to
  99. my habits of thought.  I would like an interface that seemed more
  100. "perl-ish".
  101.  
  102. &createGrammar() -- returns a grammar ID for a new grammar, to be
  103. built with registerAlternate() and registerSymbol() calls.  The
  104. grammarID scalar is actually just an integer.  The new grammar becomes
  105. the current grammar.
  106.  
  107. &setGrammar($gid) -- sets the current grammar to gid.  All Marpa
  108. routines affect only the current grammar.
  109.  
  110. ®isterSymbol($name, $pattern) -- a string giving the name and
  111. another the search pattern.  The name is to be used by another set of
  112. routines (not described) which will use names instead of symbol IDs.
  113. The pattern is only used by the default lexer supplied with Marpa.
  114. Returns the symbol ID of a newly created symbol in the current
  115. grammar.
  116.  
  117. ®isterAlternate($value, $lhs, @rhs) -- returns the production ID of
  118. a new production in the current grammar.  The $lhs is the symbol ID of
  119. its left hand side, and @rhs is a list (possibly empty) of symbol IDs
  120. for the right hand side.  Value is the string to be evaluated when
  121. translating the parse tree for this grammar.
  122.  
  123. ®isterToken($value, @sidList) -- used to build the sentence to be
  124. parsed.  $value is the string that will be passed up (unevaluated) to
  125. the upper levels of the parse tree.  The @sidList is the list of
  126. symbol IDs which are possible choices for this token.
  127.  
  128. &parse($sid) -- the main routine.  Returns the result of evaluating
  129. the parse tree, or undefined if there were no more parses.  Repeated
  130. calls return evaluations of alternative parse trees, if the grammar
  131. parses the sentence ambiguously.  $sid is the start symbol to use.
  132. The code in this routine is the heart of the parser, and is very hard
  133. to figure out.  The algorithm comes from the two volume _The Theory of
  134. Parsing, Translation and Compiling_ by Aho & Ullman, and I don't
  135. recommend you bother trying to figure out what's going on here unless
  136. you read that section of the book (Vol. I, pp. 289-297).  The code in
  137. the other routines should be accessible to the determined Perl hacker.
  138.  
  139. &clearParse() -- for parsing ambiguous grammars, &parse save its
  140. intermediate results.  This routine clears them, and deletes all
  141. tokens in the current sentence.
  142.  
  143. Marpa, Milarepa, Tilopa and Naropa are the names of Tibetan saints.
  144. Marpa the Translator was instrumental in bringing Indian Buddhist
  145. texts to Tibet, which task involved three dangerous journeys across
  146. the Himalayas, extensive fund raising, great scholarship, linguistic
  147. ability and deep spiritual development.
  148.  
  149. Cheers!
  150.  
  151. Jeffrey Kegler, Independent UNIX Consultant, Algorists, Inc.
  152. jeffrey@algor2.ALGORISTS.COM or uunet!algor2!jeffrey
  153. 137 E Fremont AVE #122, Sunnyvale CA 94087
  154. "No wonder the gods smile so seldom -- we so often fail to notice."
  155. From _Stardance_ by Spider and Jeanne Robinson
  156.  
  157. #!/bin/sh
  158. # This is a shell archive (produced by shar 3.49)
  159. # To extract the files from this archive, save it to a file, remove
  160. # everything above the "!/bin/sh" line above, and type "sh file_name".
  161. #
  162. # made 11/06/1992 11:54 UTC by jeffrey@netcom
  163. # Source directory /u25/jeffrey/marpa
  164. #
  165. # existing files will NOT be overwritten unless -c is specified
  166. #
  167. # This shar contains:
  168. # length  mode       name
  169. # ------ ---------- ------------------------------------------
  170. #   7038 -rw-r--r-- marpa.pl
  171. #   4221 -rw-r--r-- milarepa.pl
  172. #    888 -rw-r--r-- mrtest.pl
  173. #   1101 -rw-r--r-- mrtest2.pl
  174. #    966 -rw-r--r-- naropa.pl
  175. #    865 -rw-r--r-- test.pl
  176. #    700 -rw-r--r-- test2.pl
  177. #    813 -rw-r--r-- tilopa.pl
  178. #    160 -rw-r--r-- test.mr
  179. #    244 -rw-r--r-- test2.mr
  180. #
  181. # ============= marpa.pl ==============
  182. if test -f 'marpa.pl' -a X"$1" != X"-c"; then
  183.     echo 'x - skipping marpa.pl (File already exists)'
  184. else
  185. echo 'x - extracting marpa.pl (Text)'
  186. sed 's/^X//' << 'SHAR_EOF' > 'marpa.pl' &&
  187. package Marpa;
  188. X
  189. $debug = 0;
  190. X
  191. $currentGrammar = 1;
  192. $nextGrammar = 2;
  193. X
  194. $nextAlternate = 1;
  195. $nextSymbol = 1;
  196. X
  197. $listTemplate = "l*";
  198. X
  199. sub main'createGrammar
  200. {
  201. X    local($ret) = $nextGrammar++;
  202. X    return $ret;
  203. }
  204. X
  205. sub main'setGrammar
  206. {
  207. X    local($gid) = @_;
  208. X    $currentGrammar = $gid;
  209. }
  210. X
  211. sub main'clearParse
  212. {
  213. X    @TokenValue = ();
  214. X    @Token = ();
  215. X    @L1Position = ();
  216. X    @L1 = ();
  217. X    @L2 = ();
  218. X    $inProgress = 0;
  219. }
  220. X
  221. sub main'registerSymbol
  222. {
  223. X    local($name, $pattern) = @_;
  224. X    local($ret) = $nextSymbol++;
  225. X    $symbolName{$currentGrammar, $ret} = $name;
  226. X    $symbolID{$currentGrammar, $name} = $ret;
  227. X    $symbolPattern{$currentGrammar, $ret} = $pattern if defined $pattern;
  228. X    return $ret;
  229. }
  230. X
  231. sub main'requireSymbol
  232. {
  233. X    local($name) = @_;
  234. X    local($ret) = $symbolID{$currentGrammar, $name};
  235. X    $ret = &main'registerSymbol($name) unless defined $ret;
  236. X    return $ret;
  237. }
  238. X
  239. sub main'requirePattern
  240. {
  241. X    local($name, $pattern) = @_;
  242. X    local($sid) = &main'requireSymbol($name);
  243. X    $symbolPattern{$currentGrammar, $sid} = $pattern;
  244. X    return $sid;
  245. }
  246. X
  247. sub main'symbolName
  248. {
  249. X    local($sid) = @_;
  250. X    return $symbolName{$currentGrammar, $sid};
  251. }
  252. X
  253. sub main'terminatorSymbol
  254. {
  255. X    local($sid) = @_;
  256. X    $terminator{$currentGrammar, $sid} = 1;
  257. }
  258. X
  259. sub main'discardSymbol
  260. {
  261. X    local($sid) = @_;
  262. X    $discard{$currentGrammar, $sid} = 1;
  263. }
  264. X
  265. sub main'registerAlternate
  266. {
  267. X    local($value, $lhs, @rhs) = @_;
  268. X    local($alt) = $nextAlternate++;
  269. X    print "Registering alternate $alt, $lhs = " . join(",", @rhs) .
  270. X    " -> \"$value\"\n" if $debug;
  271. X    $Value{$currentGrammar, $alt} = $value;
  272. X    $LHS{$currentGrammar, $alt} = $lhs;
  273. X    $RHS{$currentGrammar, $alt} = pack($listTemplate, @rhs);
  274. X    local(@altList) = unpack($listTemplate,
  275. X    $Alternate{$currentGrammar, $lhs});
  276. X    push(@altList, $alt);
  277. X    $Alternate{$currentGrammar, $lhs} =
  278. X    pack($listTemplate, sort { $a <=> $b } @altList);
  279. X    return $alt;
  280. }
  281. X
  282. sub main'registerToken
  283. {
  284. X    package Marpa;
  285. X    local($value, @symbolList) = @_;
  286. X
  287. X    push(@TokenValue, $value);
  288. X    push(@Token, pack($listTemplate, @symbolList));
  289. }
  290. X
  291. $inProgress = 0;
  292. X
  293. $normal = 1;
  294. $backtrack = 2;
  295. $fail = 3;
  296. $succeed = 4;
  297. X
  298. sub elementOf
  299. {
  300. X    local($element, @set) = @_;
  301. X
  302. X    foreach $setElement (@set)
  303. X    {
  304. X    return 1 if $element == $setElement;
  305. X    }
  306. X    return 0;
  307. }
  308. X
  309. %evalValues = ();
  310. X
  311. sub main'value
  312. {
  313. X    local($sid, $occurrence) = @_;
  314. X    $occurrence = 1 unless defined $occurrence;
  315. X    local($ret) = $evalValues{$sid, $occurrence};
  316. X    $ret = "[?value($sid, occurrence)?]" unless defined $ret;
  317. X    return $ret;
  318. }
  319. X
  320. sub main'v
  321. {
  322. X    local($name, $occurrence) = @_;
  323. X    $sid = &main'requireSymbol($name);
  324. X    return &main'value($sid, $occurrence);
  325. }
  326. X
  327. sub symbolEval
  328. {
  329. X    local($ret);
  330. X    local($L1pos) = $L1Position[$evalPosition];
  331. X    local($L1) = $L1[$evalPosition];
  332. X    print "Starting \$evalPosition=$evalPosition," .
  333. X    "\$L1pos=$L1pos," .
  334. X    "\$L1=$L1\n" if $debug;
  335. X    $evalPosition++;
  336. X    return $TokenValue[$L1pos] if $L1pos >= $[;
  337. X    local(@RHSCount) = ();
  338. X    local(@RHS) = unpack($listTemplate, $RHS{$currentGrammar, $L1});
  339. X    local(%Values) = ();
  340. X    local($i);
  341. X    for ($i = $[; $i <= $#RHS; $i++)
  342. X    {
  343. X    local($sym) = $RHS[$i];
  344. X    local($val) = &symbolEval();
  345. X    return $ret if $parseReject;
  346. X    $RHSCount[$sym] = 0 unless defined $RHSCount[$sym];
  347. X    $RHSCount[$sym]++;
  348. X    $Values{$sym, $RHSCount[$sym]} = $val;
  349. X    }
  350. X    print "Evaluating \$L1pos=$L1pos," .  "\$L1=$L1\n" if $debug;
  351. X    %evalValues = %Values;
  352. X    $evalString = $Value{$currentGrammar, $L1};
  353. X    print "Evaluating \"$evalString\"\n" if $debug;
  354. X    die "Marpa: no value, production $L1, grammar $currentGrammar\n"
  355. X    unless defined $evalString;
  356. X    package main;
  357. X    die "Marpa: unable to eval \"$Marpa'evalString\", $@\n"
  358. X    unless $Marpa'ret = eval $Marpa'evalString;
  359. X    package Marpa;
  360. }
  361. X
  362. sub main'parse
  363. {
  364. X    local($ret);
  365. X    local($startSymbol) = @_;
  366. X
  367. X    if ($inProgress)
  368. X    {
  369. X    $state = $backtrack;
  370. X    } else {
  371. X    $state = $normal;
  372. X    $position = $[;
  373. X    @L1 = ();
  374. X    @L1Position = ();
  375. X    @L2 = ($startSymbol);
  376. X    $inProgress++;
  377. X    }
  378. X
  379. X    config: for (;;)
  380. X    {
  381. X    if ($debug)
  382. X    {
  383. X        if ($state == $normal)
  384. X        {
  385. X        print "q";
  386. X        } elsif ($state == $backtrack)
  387. X        {
  388. X        print "b";
  389. X        } elsif ($state == $succeed)
  390. X        {
  391. X        print "t";
  392. X        } else
  393. X        {
  394. X        print "?";
  395. X        }
  396. X        print ",";
  397. X        print $position+1;
  398. X        print ",";
  399. X        if ($#L1 < $[) { print "e"; }
  400. X        else {
  401. X        local($i);
  402. X        for ($i=$[; $i<=$#L1; $i++)
  403. X        {
  404. X            if ($L1Position[$i] >= $[)
  405. X            {
  406. X            print $symbolName{$currentGrammar, $L1[$i]};
  407. X            } else {
  408. X            local($symbol) = $LHS{$currentGrammar, $L1[$i]};
  409. X            local($altList) = $Alternate{$currentGrammar, $symbol};
  410. X            local(@altList) = unpack($listTemplate, $altList);
  411. X            local($j);
  412. X            altCount: for ($j = $[; $j <= $#altList; $j++)
  413. X            {
  414. X                last altCount if $altList[$j] == $L1[$i];
  415. X            }
  416. X            print join("",
  417. X            "<$symbolName{$currentGrammar, $symbol}",
  418. X            ($j+1),
  419. X            ">"
  420. X            );
  421. X            }
  422. X        }
  423. X        }
  424. X        print ",";
  425. X        if ($#L2 < $[) { print "e" if $state == $succeed; }
  426. X        else {
  427. X        local($i);
  428. X        for ($i=$#L2; $i>=$[; $i--)
  429. X        {
  430. X            print "<$symbolName{$currentGrammar, $L2[$i]}>";
  431. X        }
  432. X        }
  433. X        print "$" unless $state == $succeed;
  434. X        print "\n";
  435. X    }
  436. X
  437. X    if ($state == $fail)
  438. X    {
  439. X        return $ret;
  440. X    }
  441. X
  442. X    if ($state == $normal)
  443. X    {
  444. X        if ($#L2 == $[ - 1)
  445. X        {
  446. X        $state = $position > $#Token ? $succeed : $backtrack;
  447. X        next config;
  448. X        }
  449. X
  450. X        if (&elementOf($L2[$#L2],
  451. X        unpack($listTemplate, $Token[$position])))
  452. X        {
  453. X        push(@L1, pop(@L2));
  454. X        push(@L1Position, $position);
  455. X        $position++;
  456. X        next config;
  457. X        }
  458. X
  459. X        local($altList) = $Alternate{$currentGrammar, $L2[$#L2]};
  460. X        if (defined $altList)
  461. X        {
  462. X        local(@altList) = unpack($listTemplate, $altList);
  463. X        local($alt) = shift @altList;
  464. X        push(@L1, $alt);
  465. X        push(@L1Position, $[ - 1);
  466. X        pop(@L2);
  467. X        push(@L2, reverse unpack($listTemplate,
  468. X            $RHS{$currentGrammar, $alt}));
  469. X        next config;
  470. X        }
  471. X
  472. X        $state = $backtrack;
  473. X        next config;
  474. X
  475. X    } # end of if NORMAL
  476. X
  477. X    if ($state == $backtrack)
  478. X    {
  479. X        if ($#L1 < $[)
  480. X        {
  481. X        $state = $fail;
  482. X        next config;
  483. X        }
  484. X
  485. X        if ($L1Position[$#L1] >= $[)
  486. X        {
  487. X        $position--;
  488. X        push(@L2, pop(@L1));
  489. X        pop(@L1Position);
  490. X        next config;
  491. X        }
  492. X
  493. X        $oldAlt = pop(@L1);
  494. X        pop(@L1Position);
  495. X        foreach $element (unpack($listTemplate,
  496. X        $RHS{$currentGrammar, $oldAlt}))
  497. X        {
  498. X        pop(@L2);
  499. X        }
  500. X
  501. X        @altList = unpack($listTemplate,
  502. X        $Alternate{$currentGrammar, $LHS{$currentGrammar, $oldAlt}});
  503. X
  504. X        altPass: while ($element = shift(@altList))
  505. X        {
  506. X        last altPass if $element == $oldAlt;
  507. X        }
  508. X
  509. X        $newAlt = shift(@altList);
  510. X
  511. X        if (defined $newAlt)
  512. X        {
  513. X        $state = $normal;
  514. X        push(@L1, $newAlt);
  515. X        push(@L1Position, $[ - 1);
  516. X        push(@L2, reverse unpack($listTemplate,
  517. X            $RHS{$currentGrammar, $newAlt}));
  518. X        next config;
  519. X        }
  520. X
  521. X        push(@L2, $LHS{$currentGrammar, $oldAlt});
  522. X        next config;
  523. X
  524. X    } # end of if BACKTRACK
  525. X
  526. X    last config;
  527. X
  528. X    }
  529. X
  530. X    $evalPosition = $[;
  531. X    $parseReject = 0;
  532. X    local($val) = &symbolEval();
  533. X    $ret = $val if (!$parseReject);
  534. X    return $ret;
  535. }
  536. X
  537. 1;
  538. X
  539. package main;
  540. SHAR_EOF
  541. chmod 0644 marpa.pl ||
  542. echo 'restore of marpa.pl failed'
  543. Wc_c="`wc -c < 'marpa.pl'`"
  544. test 7038 -eq "$Wc_c" ||
  545.     echo 'marpa.pl: original size 7038, current size' "$Wc_c"
  546. fi
  547. # ============= milarepa.pl ==============
  548. if test -f 'milarepa.pl' -a X"$1" != X"-c"; then
  549.     echo 'x - skipping milarepa.pl (File already exists)'
  550. else
  551. echo 'x - extracting milarepa.pl (Text)'
  552. sed 's/^X//' << 'SHAR_EOF' > 'milarepa.pl' &&
  553. require "naropa.pl";
  554. X
  555. $S_Semicolon = &main'registerSymbol("semicolon", ";");
  556. &main'terminatorSymbol($S_Semicolon);
  557. X
  558. $S_StringPiece =
  559. X    &main'registerSymbol("string piece", "\"((\\\\.)|([^\\\"]))*\"");
  560. X
  561. $S_Whitespace = &main'registerSymbol("whitespace", "\\s+");
  562. &main'discardSymbol($S_Whitespace);
  563. X
  564. $S_Comment = &main'registerSymbol("comment", "#[^\n]*\n");
  565. &main'discardSymbol($S_Comment);
  566. X
  567. $S_ConcatenateSign = &main'registerSymbol("concatenate sign", "\\\.");
  568. $S_NameComponent = &main'registerSymbol("name component", "\\w+");
  569. $S_Tilde = &main'registerSymbol("tilde", "~");
  570. $S_ProduceSign = &main'registerSymbol("produce sign", "::=");
  571. X
  572. # action ::= lex pattern | production;
  573. $S_Action = &main'registerSymbol("action");
  574. $S_LexPattern = &main'registerSymbol("lex pattern");
  575. $S_Production = &main'registerSymbol("production");
  576. &main'registerAlternate('&value($S_LexPattern)', $S_Action, $S_LexPattern);
  577. &main'registerAlternate('&value($S_Production)', $S_Action, $S_Production);
  578. X
  579. # lex pattern ::= symbol name . tilde . string
  580. $S_SymbolName = &main'registerSymbol("symbol name");
  581. &main'registerAlternate(
  582. X    qq/join("",
  583. X    "&requirePattern('",
  584. X        &value($S_SymbolName),
  585. X        "', ",
  586. X        &value($S_StringPiece),
  587. X        ");\n")/,
  588. X    $S_LexPattern, $S_SymbolName, $S_Tilde, $S_StringPiece);
  589. X
  590. # symbol name ::= name component list
  591. $S_NameComponentList = &main'registerSymbol("name component list");
  592. &main'registerAlternate(
  593. X    '&value($S_NameComponentList)',
  594. X    $S_SymbolName, $S_NameComponentList);
  595. X
  596. # name component list ::=
  597. #     name component |
  598. #     name component . name component list;
  599. &main'registerAlternate('&value($S_NameComponent)',
  600. X    $S_NameComponentList, $S_NameComponent);
  601. &main'registerAlternate(
  602. X    'join(" ",&value($S_NameComponent),&value($S_NameComponentList))',
  603. X    $S_NameComponentList, $S_NameComponent, $S_NameComponentList);
  604. X
  605. # string ::= string piece list
  606. $S_String = &main'registerSymbol("string");
  607. $S_StringPieceList = &main'registerSymbol("string piece list");
  608. &main'registerAlternate(
  609. X    '&value($S_StringPieceList)',
  610. X    $S_String, $S_StringPieceList);
  611. X
  612. # string piece list ::=
  613. #    string piece |
  614. #    string piece . string piece list;
  615. &main'registerAlternate(
  616. X    '&value($S_StringPiece)',
  617. X    $S_StringPieceList, $S_StringPiece);
  618. &main'registerAlternate(
  619. X    'join("", &value($S_StringPiece), &value($S_StringPieceList))',
  620. X    $S_StringPieceList, $S_StringPiece, $S_StringPieceList);
  621. X
  622. # production ::=
  623. #    production proper |
  624. #    production proper . production action;
  625. $S_ProductionProper = &main'registerSymbol("production proper");
  626. $S_ProductionAction = &main'registerSymbol("production action");
  627. ®isterAlternate(
  628. X    qq/join("",
  629. X    '&defaultAction(\n  ',
  630. X    &value($S_ProductionProper),
  631. X    ');\n')/,
  632. X    $S_Production, $S_ProductionProper);
  633. ®isterAlternate(
  634. X    qq/join("",
  635. X    '®isterAlternate(\n  ',
  636. X    &value($S_ProductionAction),
  637. X    '\n   ,',
  638. X    &value($S_ProductionProper),
  639. X    ');\n')/,
  640. X    $S_Production, $S_ProductionProper, $S_ProductionAction);
  641. X
  642. # production action ::= string piece;
  643. &main'registerAlternate(
  644. X    '&value($S_StringPiece)',
  645. X    $S_ProductionAction, $S_StringPiece);
  646. X
  647. # production proper ::= lhs . produce sign . rhs;
  648. $S_LHS = &main'registerSymbol("lhs");
  649. $S_RHS = &main'registerSymbol("rhs");
  650. ®isterAlternate(
  651. X    qq/join('',
  652. X    '&requireSymbol("',
  653. X    &value($S_LHS),
  654. X    '")\n',
  655. X    &value($S_RHS))/,
  656. X    $S_ProductionProper, $S_LHS, $S_ProduceSign, $S_RHS
  657. );
  658. X
  659. # lhs ::= symbol name;
  660. ®isterAlternate('&value($S_SymbolName)', $S_LHS, $S_SymbolName);
  661. X
  662. # rhs ::= symbol list;
  663. $S_SymbolList = &main'registerSymbol("symbol list");
  664. ®isterAlternate(
  665. X    qq/&value($S_SymbolList)/,
  666. X    $S_RHS, $S_SymbolList
  667. );
  668. X
  669. # symbol list ::=
  670. #    symbol name |
  671. #    symbol name . concatenate symbol . symbol list;
  672. &main'registerAlternate(
  673. X    qq/join(''
  674. X    ,'  ,&requireSymbol("'
  675. X    ,&value($S_SymbolName)
  676. X    ,'")\n'
  677. X    )/,
  678. X    $S_SymbolList, $S_SymbolName);
  679. ®isterAlternate(
  680. X    qq/join('',
  681. X    '  ,&requireSymbol("',
  682. X    &value($S_SymbolName),
  683. X    '")\n',
  684. X    &value($S_SymbolList)
  685. X    )/,
  686. X    $S_SymbolList, $S_SymbolName,
  687. X    $S_ConcatenateSign, $S_SymbolList);
  688. X
  689. print "\nrequire 'naropa.pl';\n";
  690. X
  691. # $Marpa'debug = 1;
  692. &naropa($S_Action);
  693. X
  694. print "\n&naropa(&requireSymbol('start symbol'));\n";
  695. SHAR_EOF
  696. chmod 0644 milarepa.pl ||
  697. echo 'restore of milarepa.pl failed'
  698. Wc_c="`wc -c < 'milarepa.pl'`"
  699. test 4221 -eq "$Wc_c" ||
  700.     echo 'milarepa.pl: original size 4221, current size' "$Wc_c"
  701. fi
  702. # ============= mrtest.pl ==============
  703. if test -f 'mrtest.pl' -a X"$1" != X"-c"; then
  704.     echo 'x - skipping mrtest.pl (File already exists)'
  705. else
  706. echo 'x - extracting mrtest.pl (Text)'
  707. sed 's/^X//' << 'SHAR_EOF' > 'mrtest.pl' &&
  708. X
  709. require 'naropa.pl';
  710. # "start symbol ::= E;"
  711. &defaultAction(
  712. X  &requireSymbol("start symbol")
  713. X  ,&requireSymbol("E")
  714. );
  715. X
  716. # "E ::= T;"
  717. &defaultAction(
  718. X  &requireSymbol("E")
  719. X  ,&requireSymbol("T")
  720. );
  721. X
  722. # "E ::= T . plus sign . E;"
  723. &defaultAction(
  724. X  &requireSymbol("E")
  725. X  ,&requireSymbol("T")
  726. X  ,&requireSymbol("plus sign")
  727. X  ,&requireSymbol("E")
  728. );
  729. X
  730. # "T ::= F ;"
  731. &defaultAction(
  732. X  &requireSymbol("T")
  733. X  ,&requireSymbol("F")
  734. );
  735. X
  736. # "T ::= F . times sign . T;"
  737. &defaultAction(
  738. X  &requireSymbol("T")
  739. X  ,&requireSymbol("F")
  740. X  ,&requireSymbol("times sign")
  741. X  ,&requireSymbol("T")
  742. );
  743. X
  744. # "F ::= number;"
  745. &defaultAction(
  746. X  &requireSymbol("F")
  747. X  ,&requireSymbol("number")
  748. );
  749. X
  750. # "number ~ "\\d+";"
  751. &requirePattern('number', "\\d+");
  752. X
  753. # "plus sign ~ "\\+";"
  754. &requirePattern('plus sign', "\\+");
  755. X
  756. # "times sign ~ "\\*";"
  757. &requirePattern('times sign', "\\*");
  758. X
  759. X
  760. &naropa(&requireSymbol('start symbol'));
  761. SHAR_EOF
  762. chmod 0644 mrtest.pl ||
  763. echo 'restore of mrtest.pl failed'
  764. Wc_c="`wc -c < 'mrtest.pl'`"
  765. test 888 -eq "$Wc_c" ||
  766.     echo 'mrtest.pl: original size 888, current size' "$Wc_c"
  767. fi
  768. # ============= mrtest2.pl ==============
  769. if test -f 'mrtest2.pl' -a X"$1" != X"-c"; then
  770.     echo 'x - skipping mrtest2.pl (File already exists)'
  771. else
  772. echo 'x - extracting mrtest2.pl (Text)'
  773. sed 's/^X//' << 'SHAR_EOF' > 'mrtest2.pl' &&
  774. X
  775. require 'naropa.pl';
  776. # "start symbol ::= E  "&v('E')";"
  777. ®isterAlternate(
  778. X  "&v('E')"
  779. X   ,&requireSymbol("start symbol")
  780. X  ,&requireSymbol("E")
  781. );
  782. X
  783. # "E ::= T  "&v('T')";"
  784. ®isterAlternate(
  785. X  "&v('T')"
  786. X   ,&requireSymbol("E")
  787. X  ,&requireSymbol("T")
  788. );
  789. X
  790. # "E ::= T . plus sign . E  "&v('T')+&v('E')";"
  791. ®isterAlternate(
  792. X  "&v('T')+&v('E')"
  793. X   ,&requireSymbol("E")
  794. X  ,&requireSymbol("T")
  795. X  ,&requireSymbol("plus sign")
  796. X  ,&requireSymbol("E")
  797. );
  798. X
  799. # "T ::= F  "&v('F')";"
  800. ®isterAlternate(
  801. X  "&v('F')"
  802. X   ,&requireSymbol("T")
  803. X  ,&requireSymbol("F")
  804. );
  805. X
  806. # "T ::= F . times sign . T "&v('F')*&v('T')";"
  807. ®isterAlternate(
  808. X  "&v('F')*&v('T')"
  809. X   ,&requireSymbol("T")
  810. X  ,&requireSymbol("F")
  811. X  ,&requireSymbol("times sign")
  812. X  ,&requireSymbol("T")
  813. );
  814. X
  815. # "F ::= number "&v('number')";"
  816. ®isterAlternate(
  817. X  "&v('number')"
  818. X   ,&requireSymbol("F")
  819. X  ,&requireSymbol("number")
  820. );
  821. X
  822. # "number ~ "\\d+";"
  823. &requirePattern('number', "\\d+");
  824. X
  825. # "plus sign ~ "\\+";"
  826. &requirePattern('plus sign', "\\+");
  827. X
  828. # "times sign ~ "\\*";"
  829. &requirePattern('times sign', "\\*");
  830. X
  831. X
  832. &naropa(&requireSymbol('start symbol'));
  833. SHAR_EOF
  834. chmod 0644 mrtest2.pl ||
  835. echo 'restore of mrtest2.pl failed'
  836. Wc_c="`wc -c < 'mrtest2.pl'`"
  837. test 1101 -eq "$Wc_c" ||
  838.     echo 'mrtest2.pl: original size 1101, current size' "$Wc_c"
  839. fi
  840. # ============= naropa.pl ==============
  841. if test -f 'naropa.pl' -a X"$1" != X"-c"; then
  842.     echo 'x - skipping naropa.pl (File already exists)'
  843. else
  844. echo 'x - extracting naropa.pl (Text)'
  845. sed 's/^X//' << 'SHAR_EOF' > 'naropa.pl' &&
  846. require "tilopa.pl";
  847. X
  848. sub defaultAction
  849. {
  850. X    local($lhs, @rhs) = @_;
  851. X    local(@action);
  852. X    push(@action, "join('','", &main'symbolName($lhs), "=',");
  853. X    local(@rhsList) = ();
  854. X    foreach $rhs (@rhs)
  855. X    {
  856. X    push(@rhsList, "'<'", "&value($rhs)", "'>'", "','");
  857. X    }
  858. X    pop(@rhsList); # pop extra comma
  859. X    push(@action, join(",", @rhsList));
  860. X    push(@action, ")");
  861. X    &main'registerAlternate(join('', @action), $lhs, @rhs);
  862. }
  863. X
  864. sub naropa
  865. {
  866. X    local($top) = @_;
  867. X    local($line);
  868. X    line: while ($line = <main'STDIN>)
  869. X    {
  870. X    chop $line;
  871. X    while (length($line))
  872. X    {
  873. X        print "# \"$line\"\n";
  874. X        local($before) = length($line);
  875. X        $line = &main'lex($line);
  876. X        local($after) = length($line);
  877. X        local($ret);
  878. X        if ($after == $before)
  879. X        {
  880. X        $ret = "Lexer failed!!!, line=\"$line\"";
  881. X        $line = "";
  882. X        } else
  883. X        {
  884. X        $ret = "Parse failed!!!"
  885. X            unless $ret = &main'parse($top);
  886. X        }
  887. X        print "$ret\n";
  888. X        &main'clearParse();
  889. X    }
  890. X    }
  891. }
  892. X
  893. 1;
  894. SHAR_EOF
  895. chmod 0644 naropa.pl ||
  896. echo 'restore of naropa.pl failed'
  897. Wc_c="`wc -c < 'naropa.pl'`"
  898. test 966 -eq "$Wc_c" ||
  899.     echo 'naropa.pl: original size 966, current size' "$Wc_c"
  900. fi
  901. # ============= test.pl ==============
  902. if test -f 'test.pl' -a X"$1" != X"-c"; then
  903.     echo 'x - skipping test.pl (File already exists)'
  904. else
  905. echo 'x - extracting test.pl (Text)'
  906. sed 's/^X//' << 'SHAR_EOF' > 'test.pl' &&
  907. require "marpa.pl";
  908. X
  909. $SID_E = ®isterSymbol("E");
  910. $SID_Plus = ®isterSymbol("+", "\+");
  911. $SID_T = ®isterSymbol("T");
  912. $SID_Times = ®isterSymbol("*", "\*");
  913. $SID_F = ®isterSymbol("F");
  914. $SID_a = ®isterSymbol("a", "\d*");
  915. X
  916. ®isterAlternate("'E(' . &value($SID_T) . ',' . " .
  917. X    " &value($SID_Plus) . ',' . &value($SID_E) . ')'",
  918. X    $SID_E, $SID_T, $SID_Plus, $SID_E);
  919. ®isterAlternate("'E(' . &value($SID_T) . ')'",
  920. X    $SID_E, $SID_T);
  921. ®isterAlternate("'T(' . &value($SID_F) . ',' . " .
  922. X    " &value($SID_Times) . ',' &value($SID_T) . ')'",
  923. X    $SID_T, $SID_F, $SID_Times, $SID_T);
  924. ®isterAlternate("'T(' . &value($SID_F) . ')'",
  925. X    $SID_T, $SID_F);
  926. ®isterAlternate("'F(' . &value($SID_a) . ')'",
  927. X    $SID_F, $SID_a);
  928. X
  929. ®isterToken("a", $SID_a);
  930. ®isterToken("+", $SID_Plus);
  931. ®isterToken("a", $SID_a);
  932. X
  933. print &parse($SID_E);
  934. print "\n";
  935. SHAR_EOF
  936. chmod 0644 test.pl ||
  937. echo 'restore of test.pl failed'
  938. Wc_c="`wc -c < 'test.pl'`"
  939. test 865 -eq "$Wc_c" ||
  940.     echo 'test.pl: original size 865, current size' "$Wc_c"
  941. fi
  942. # ============= test2.pl ==============
  943. if test -f 'test2.pl' -a X"$1" != X"-c"; then
  944.     echo 'x - skipping test2.pl (File already exists)'
  945. else
  946. echo 'x - extracting test2.pl (Text)'
  947. sed 's/^X//' << 'SHAR_EOF' > 'test2.pl' &&
  948. require "marpa.pl";
  949. X
  950. $SID_E = ®isterSymbol("E");
  951. $SID_Plus = ®isterSymbol("+");
  952. $SID_T = ®isterSymbol("T");
  953. $SID_Times = ®isterSymbol("*");
  954. $SID_F = ®isterSymbol("F");
  955. $SID_a = ®isterSymbol("a");
  956. X
  957. ®isterAlternate("&value($SID_T)+&value($SID_E)",
  958. X    $SID_E, $SID_T, $SID_Plus, $SID_E);
  959. ®isterAlternate("&value($SID_T)",
  960. X    $SID_E, $SID_T);
  961. ®isterAlternate("&value($SID_F)*&value($SID_T)",
  962. X    $SID_T, $SID_F, $SID_Times, $SID_T);
  963. ®isterAlternate("&value($SID_F)",
  964. X    $SID_T, $SID_F);
  965. ®isterAlternate("&value($SID_a)",
  966. X    $SID_F, $SID_a);
  967. X
  968. ®isterToken("5", $SID_a);
  969. ®isterToken("+", $SID_Plus);
  970. ®isterToken("6", $SID_a);
  971. X
  972. print &parse($SID_E);
  973. print "\n";
  974. SHAR_EOF
  975. chmod 0644 test2.pl ||
  976. echo 'restore of test2.pl failed'
  977. Wc_c="`wc -c < 'test2.pl'`"
  978. test 700 -eq "$Wc_c" ||
  979.     echo 'test2.pl: original size 700, current size' "$Wc_c"
  980. fi
  981. # ============= tilopa.pl ==============
  982. if test -f 'tilopa.pl' -a X"$1" != X"-c"; then
  983.     echo 'x - skipping tilopa.pl (File already exists)'
  984. else
  985. echo 'x - extracting tilopa.pl (Text)'
  986. sed 's/^X//' << 'SHAR_EOF' > 'tilopa.pl' &&
  987. require "marpa.pl";
  988. X
  989. package Tilopa;
  990. X
  991. $debug = 0;
  992. X
  993. sub main'lex
  994. {
  995. X    local($input) = @_;
  996. X
  997. X    local($key);
  998. X    inputpass: while (length($input))
  999. X    {
  1000. X    study $input;
  1001. X    pattern: foreach $key (keys %Marpa'symbolPattern)
  1002. X    {
  1003. X        local($grammar, $sid) = split($;, $key);
  1004. X        next pattern unless $grammar == $Marpa'currentGrammar;
  1005. X        local($pattern) = $Marpa'symbolPattern{$key};
  1006. X        print "Trying pattern \"$pattern\"\n" if $debug;
  1007. X        next pattern unless $input =~ /^$pattern/;
  1008. X        $input = $';
  1009. X        next inputpass if $Marpa'discard{$grammar, $sid};
  1010. X        last inputpass if $Marpa'terminator{$grammar, $sid};
  1011. X        &main'registerToken($&, $sid);
  1012. X        print "Registering $& as $Marpa'symbolName{$grammar, $sid}\n"
  1013. X        if $debug;
  1014. X        next inputpass;
  1015. X    }
  1016. X    last inputpass;
  1017. X    }
  1018. X    return $input;
  1019. }
  1020. X
  1021. 1;
  1022. package main;
  1023. SHAR_EOF
  1024. chmod 0644 tilopa.pl ||
  1025. echo 'restore of tilopa.pl failed'
  1026. Wc_c="`wc -c < 'tilopa.pl'`"
  1027. test 813 -eq "$Wc_c" ||
  1028.     echo 'tilopa.pl: original size 813, current size' "$Wc_c"
  1029. fi
  1030. # ============= test.mr ==============
  1031. if test -f 'test.mr' -a X"$1" != X"-c"; then
  1032.     echo 'x - skipping test.mr (File already exists)'
  1033. else
  1034. echo 'x - extracting test.mr (Text)'
  1035. sed 's/^X//' << 'SHAR_EOF' > 'test.mr' &&
  1036. start symbol ::= E;
  1037. E ::= T;
  1038. E ::= T . plus sign . E;
  1039. T ::= F ;
  1040. T ::= F . times sign . T;
  1041. F ::= number;
  1042. number ~ "\\d+";
  1043. plus sign ~ "\\+";
  1044. times sign ~ "\\*";
  1045. SHAR_EOF
  1046. chmod 0644 test.mr ||
  1047. echo 'restore of test.mr failed'
  1048. Wc_c="`wc -c < 'test.mr'`"
  1049. test 160 -eq "$Wc_c" ||
  1050.     echo 'test.mr: original size 160, current size' "$Wc_c"
  1051. fi
  1052. # ============= test2.mr ==============
  1053. if test -f 'test2.mr' -a X"$1" != X"-c"; then
  1054.     echo 'x - skipping test2.mr (File already exists)'
  1055. else
  1056. echo 'x - extracting test2.mr (Text)'
  1057. sed 's/^X//' << 'SHAR_EOF' > 'test2.mr' &&
  1058. start symbol ::= E  "&v('E')";
  1059. E ::= T  "&v('T')";
  1060. E ::= T . plus sign . E  "&v('T')+&v('E')";
  1061. T ::= F  "&v('F')";
  1062. T ::= F . times sign . T "&v('F')*&v('T')";
  1063. F ::= number "&v('number')";
  1064. number ~ "\\d+";
  1065. plus sign ~ "\\+";
  1066. times sign ~ "\\*";
  1067. SHAR_EOF
  1068. chmod 0644 test2.mr ||
  1069. echo 'restore of test2.mr failed'
  1070. Wc_c="`wc -c < 'test2.mr'`"
  1071. test 244 -eq "$Wc_c" ||
  1072.     echo 'test2.mr: original size 244, current size' "$Wc_c"
  1073. fi
  1074. exit 0
  1075. -- 
  1076. Jeffrey Kegler, Independent UNIX Consultant, Algorists, Inc.
  1077. jeffrey@algor2.ALGORISTS.COM or uunet!algor2!jeffrey
  1078. 137 E Fremont AVE #122, Sunnyvale CA 94087
  1079. "Nitwit ideas are for emergencies.  You use them when you've got
  1080. nothing else to try.  If they work, they go in the Book.  Otherwise
  1081. you follow the Book, which is largely a collection of nitwit ideas
  1082. that worked." from the _Mote in God's Eye_ by Larry Niven and Jerry
  1083. Pournelle
  1084.