Gauche を PL/0 処理系にする

pl0-test.scm

;;; -*- mode: gauche -*-

(use pl0)

#!pl0

CONST m =  7, n = 85;
VAR  x, y, z, q, r;

PROCEDURE gcd;
VAR f, g;
BEGIN
  f := x; g := y;
  WHILE f # g DO BEGIN
    IF f < g THEN g := g - f;
    IF g < f THEN f := f - g
  END;
  z := f
END;

BEGIN
  x := 84;
  y := 36;
  CALL gcd;
  WRITELN z
END.

pl0.scm

;;; -*- mode: gauche -*-

(define-module pl0
  (use parser.peg)
  (use srfi-13)
  (use srfi-1)
  (use gauche.lazy)
  (export parse-pl0))

(select-module pl0)

(define %ws
  ($skip-many ($one-of #[ \t\r\n])))

(define %ident
  ($do (fst ($one-of #[a-zA-Z]))
       (rst ($many ($one-of #[a-zA-Z0-9])))
       %ws
       ($return (string-downcase (apply string fst rst)))))

(define %number
  ($lift (lambda (x _) x)
         ($lift (lambda(x)(string->number (apply string x)))
                ($many ($one-of #[0-9]) 1))
         %ws))

(define entry-table
  '(("odd"   . odd)
    ("const" . const)
    ("var"   . var)
    ("procedure" . procedure)
    ("begin" . begin)
    ("end"   . end)
    ("if"    . if)
    ("then"  . then)
    ("while" . while)
    ("do"    . do)
    ("call"  . call)
    ("writeln" . writeln)))

(define ($/ parser . parsers)
  (if (null? parsers)
      parser
      ($or ($try parser) (apply $/ parsers))))

(define lex
  ($/ ($do (($s ":=")) %ws ($return ':=))
      ($do (($c #\=))  %ws ($return '=))
      ($do (($c #\#))  %ws ($return 'not))
      ($do (($s "<=")) %ws ($return '<=))
      ($do (($c #\<))  %ws ($return '<))
      ($do (($s ">=")) %ws ($return '>=))
      ($do (($c #\>))  %ws ($return '>))
      ($do (($c #\+))  %ws ($return '+))
      ($do (($c #\-))  %ws ($return '-))
      ($do (($c #\*))  %ws ($return '*))
      ($do (($c #\/))  %ws ($return '/))
      ($do (($c #\;))  %ws ($return 'separator))
      ($do (($c #\,))  %ws ($return 'comma))
      ($do (($c #\())  %ws ($return 'left-paren))
      ($do (($c #\)))  %ws ($return 'right-paren))
      ($do (($c #\.))  %ws ($return 'period))
      ($do (num %number)   ($return num))
      ($do (ident %ident)
           ($return (assoc-ref entry-table ident ident)))
      ($fail "Invalid character")))

(define (tokenize lexer)
  (lambda(lst)
    (return-result
     (let loop ((lst (drop-while (pa$ char-set-contains? #[ \t\r\n]) lst)))
       (if (null? lst)
           '()
           (receive (status token rest)
               (lexer lst)
             (if (parse-success? status)
                 (lcons token (loop rest))
                 (error 'token)))))
     '())))

(define ($eq sym :optional (default sym))
  (lambda(vs)
    (if (eq? (car vs) sym)
        (return-result default (cdr vs))
        (return-failure/expect sym vs))))

(define ($ident)
  (lambda(vs)
    (let1 ident (car vs)
      (if (string? ident)
          (return-result (string->symbol ident) (cdr vs))
          (return-failure/expect "<identify>" vs)))))

(define ($number)
  (lambda(vs)
    (let1 ident (car vs)
      (if (number? ident)
          (return-result ident (cdr vs))
          (return-failure/expect "<number>" vs)))))

(define %term
  ($lazy
   ($/ ($do (factor1 %factor)
            (op ($or ($eq '*) ($eq '/)))
            (factor2 %factor)
            ($return (list (case op ((/) 'div) ((*) '*)) factor1 factor2)))
       %factor)))

(define %sign
  ($or ($eq '+) ($eq '-)))

(define %expression
  ($/ ($do (sign1 ($optional %sign '+))
           (term1 %term)
           (sign2 %sign)
           (term2 %term)
           ($return `(,sign2 (,sign1 ,term1) ,term2)))
      ($do (sign1 ($optional %sign '+))
           (term %term)
           ($return `(,sign1 ,term)))))

(define %factor
  ($/ ($ident)
      ($number)
      ($between ($eq 'left-paren) %expression ($eq 'right-paren))))

(define %comp-op
  ($/ ($eq '<=) ($eq '>=) ($eq '=) ($eq 'not)
      ($eq '<) ($eq '>)))

(define %condition
  ($/
   ($do (($eq 'odd))
        (expr %expression)
        ($return `(odd? ,expr)))
   ($do (expr1 %expression)
        (op %comp-op)
        (expr2 %expression)
        ($return (if (eq? op 'not)
                     `(not (= ,expr1 ,expr2))
                     `(,op ,expr1 ,expr2))))))

(define %statement
  ($lazy
   ($/ %if-statement
       %while-statement
       %statements
       %call-statement
       %writeln-statement
       %assignment)))

(define %assignment
  ($do (ident ($ident))
       (($eq ':=))
       (expr %expression)
       ($return `(set! ,ident ,expr))))

(define %separator ($eq 'separator))

(define %comma ($eq 'comma))

(define %statements
  ($do (($eq 'begin))
       (statements ($sep-by %statement %separator))
       (($eq 'end))
       ($return `(begin ,@statements))))

(define %if-statement
  ($do (($eq 'if))
       (condition %condition)
       (($eq 'then))
       (statement %statement)
       ($return `(when ,condition ,statement))))

(define %while-statement
  ($do (($eq 'while))
       (condition %condition)
       (($eq 'do))
       (statement %statement)
       ($return `(do ()((not ,condition)) ,statement))))

(define %call-statement
  ($do (($eq 'call))
       (ident ($ident))
       ($return `(,ident))))

(define %writeln-statement
  ($do (($eq 'writeln))
       (expr %expression)
       ($return `(print ,expr))))

(define %const-declare
  ($between ($eq 'const)
            ($sep-by ($do (var ($ident))
                          (($eq '=))
                          (num ($number))
                          ($return (list var num)))
                     %comma)
            %separator))

(define %var-declare
  ($between ($eq 'var) ($sep-by ($ident) %comma) %separator))

(define %block
  ($do (const ($optional %const-declare '()))
       (var ($optional %var-declare '()))
       (procs ($many %procedure-define))
       (statement %statement)
       ($return
        `(let (,@const ,@(map (lambda(x)(list x #f)) var))
           ,@procs
           ,statement))))

(define %procedure-define
  ($do (($eq 'procedure))
       (ident ($ident))
       %separator
       (block %block)
       %separator
       ($return `(define (,ident) ,block))))

(define %program
  ($do
   (block %block)
   (($eq 'period))
   ($return block)))

(define (parse-pl0 port)
  (values-ref
   (peg-run-parser %program (peg-parse-port (tokenize lex) port))
   0))

(define-reader-directive 'pl0
  (^(sym port ctx)
    (parse-pl0 port)))