parser.sld

(define-library (casl parser)
  (export casl-parse-error casl-parse)
  (import (scheme base)
          (scheme char)
          (casl peg))
  (begin
    (define (subsequent-letter? ch)
      (or (char-alphabetic? ch) (char-numeric? ch)))

    (define %initial-letter
      ($one-of char-alphabetic?))
    
    (define %subsequent-letter
      ($one-of (lambda(ch)(or (char-alphabetic? ch) (char-numeric? ch)))))

    (define %identifier
      ($let* ((h %initial-letter)
              (t ($while %subsequent-letter)))
        ($return (list->string (cons h t)))))

    (define-values (register-table index-register-table)
      (let ((table '("GR0" "GR1" "GR2" "GR3" "GR4" "GR5" "GR6" "GR7")))
        (values table (cdr table))))

    (define %register
      ($let* s ((ident %identifier))
        (if (member ident register-table)
            ($return (string->symbol ident))
            ($return #f 'expect s))))

    (define %index-register
      ($let* s ((ident %identifier))
        (if (member ident index-register-table)
            ($return (string->symbol ident))
            ($return #f 'expect s))))

    (define statement-table
      '("NOP" "LD" "ST" "LAD"
        "ADDA" "ADDL" "SUBA" "SUBL"
        "AND" "OR" "XOR"
        "CPA" "CPL"
        "SLA" "SRA" "SLL" "SRL"
        "JPL" "JMI" "JNZ" "JZE" "JOV" "JUMP"
        "PUSH" "POP" "CALL" "RET"
        "SVC"
        "START" "END" "DS" "DC" "IN" "OUT" "RPUSH" "RPOP"))

    (define %label
      ($let* ((ident %identifier))
        (if (not (or (member ident statement-table)
                     (member ident register-table)))
            ($return ident)
            ($return ident 'expect))))

    (define %statement
      ($let* s ((ident %identifier))
        (if (member ident statement-table)
            ($return (string->symbol ident))
            ($return #f 'expect s))))

    (define %dec-const
      ($let* s ((sign ($optional ($char #\-) #f))
                (n ($while ($one-of char-numeric?))))
        (if (null? n)
            ($return #f 'expect s)
            ($return ((if sign - +) (string->number (list->string n)))))))

    (define (digit? ch)
      (or
       (char-numeric? ch)
       (case ch
         ((#\A #\B #\C #\D #\E #\F) #t)
         (else #f))))

    (define %hex-const
      ($order ($char #\#)
              ($let* s ((n ($while ($one-of digit?))))
                (if (null? n)
                    ($return #f 'expect s)
                    ($return (string->number (list->string n) 16))))))

    (define %num
      ($select %hex-const %dec-const))

    (define %literal
      ($let* ((lit ($order ($char #\=) ($select %num %string))))
        ($return (list 'literal lit))))

    (define %address
      ($select
       ($let* ((num ($select %num %literal %label))
               (reg ($optional ($order ($char #\,) %index-register))))
         ($return (list num reg)))))

    (define %white-space
      ($skip-while (lambda(ch)(or (eqv? ch #\space) (eqv? ch #\tab)))))

    (define %register-pair
      ($let* ((reg1 %register)
              (_ ($char #\,))
              (reg2 %register))
        ($return (list reg1 reg2))))

    (define %reg&adr
      ($let* ((reg %register)
              (_ ($char #\,))
              (adr %address))
        ($return (list reg adr))))

    (define %comment1
      ($optional
       ($order ($one-of (lambda(ch)(or (eqv? ch #\space) (eqv? ch #\tab))))
               ($skip-while (lambda(s) #t)))))

    (define %comment2
      ($optional
       ($order ($one-of (lambda(ch)(or (eqv? ch #\space) (eqv? ch #\tab))))
               %white-space
               ($optional
                ($order ($char #\;) ($skip-while (lambda(s) #t)))))))

    (define %comment3
      ($order %white-space
              ($char #\;)
              ($skip-while (lambda(s) #t))))

    (define %string
      ($let* ((_ ($char #\'))
              (s ($while ($select
                          ($one-of (lambda(ch)(not (char=? ch #\'))))
                          ($order ($char #\') ($char #\') ($return #\')))))
              (_ ($char #\')))
        ($return (list 'string (list->string s)))))

    (define %const-list
      ($split-by ($select %num %string %label) ($char #\,)))

    (define %line
      ($select
       ($let* ((label ($optional %label))
               (_ %white-space)
               (statement %statement))
         ($select
          (case statement
            ((JPL JMI JNZ JZE JOV JUMP PUSH CALL SVC)
             ($let* ((_ %white-space)
                     (adr %address)
                     (_ %comment1))
               ($return (list label statement adr))))
            ((ST LAD SLA SRA SLL SRL)
             ($let* ((_ %white-space)
                     (ra %reg&adr)
                     (_ %comment1))
               ($return (apply list label statement ra))))
            ((POP)
             ($let* ((_ %white-space)
                     (reg %register)
                     (_ %comment1))
               ($return (list label statement reg))))
            ((LD ADDA ADDL SUBA SUBL AND OR XOR CPA CPL)
             ($let* ((_ %white-space)
                     (op ($select %register-pair %reg&adr))
                     (_ %comment1))
               ($return (apply list label statement op))))
            ((RET NOP END RPUSH RPOP)
             ($order %comment2
                     ($return (list label statement))))
            ((START)
             ($let* ((entry ($optional ($order %white-space %label) #f))
                     (_ %comment1))
               ($return (list label statement entry))))
            ((DS)
             ($let* ((_ %white-space)
                     (num %num)
                     (_ %comment1))
               ($return (list label statement num))))
            ((DC)
             ($let* ((_ %white-space)
                     (cl %const-list)
                     (_ %comment1))
               ($return (apply list label statement cl))))
            ((IN OUT)
             ($let* ((_ %white-space)
                     (area %label)
                     (_ ($char #\,))
                     (len %label)
                     (_ %comment1))
               ($return (list label statement area len)))))
          ($fail "Invalid operand")))
       %comment3
       ($fail "Unknown error")))

    (define-record-type <casl-parse-error>
      (casl-parse-error message)
      casl-parse-error?
      (message casl-parse-error-message))

    (define (casl-line-parse port)
      (let ((line (read-line port)))
        (if (eof-object? line)
            line
            (let-values (((r v s) (%line (string->list line))))
              (if (and (eqv? r 'success) (null? s))
                  v
                  (raise v))))))

    (define (casl-parse port)
      (do ((i 0 (+ i 1))
           (line (casl-line-parse port) (casl-line-parse port))
           (result '() (if (pair? line) (cons line result) result)))
          ((eof-object? line) (reverse result))))
    ))

peg.sld

(define-library (casl peg)
  (export $return $fail $while $skip-while $one-of $char
          $order $select $split-by $optional $let*)
  (import (scheme base)
          (scheme case-lambda))

  (begin
    (define $return
      (case-lambda
       ((v) (lambda(s) (values 'success v s)))
       ((v state) (lambda(s) (values state v s)))
       ((v state s) (lambda(_) (values state v s)))))

    (define ($fail m)
      ($return m 'unexpect))

    (define ($while parser)
      (lambda(s)
        (let loop ((lst s)
                   (result '()))
          (if (pair? lst)
              (let-values (((r v s1)(parser lst)))
                (if (eqv? r 'success)
                    (loop s1 (cons v result))
                    (values 'success (reverse result) lst)))
              (values 'success (reverse result) lst)))))

    (define ($skip-while pred)
      (lambda(s)
        (let loop ((lst s))
          (if (pair? lst)
              (let ((v (car lst)))
                (if (pred v)
                    (loop (cdr lst))
                    (values 'success #t lst)))
              (values 'success #t lst)))))

    (define ($one-of pred)
      (lambda(s)
        (if (pair? s)
            (let ((v (car s)))
              (if (pred v)
                  (values 'success v (cdr s))
                  (values 'expect #f s)))
            (values 'expect #f s))))

    (define ($char ch)
      ($one-of (lambda(x)(eqv? x ch))))

    (define-syntax $let*
      (syntax-rules ()
        ((_ label ((var expr)) body)
         (lambda(label)
           (let-values (((r var s1) (expr label)))
             (case r
               ((success) (body s1))
               (else (values r var label))))))
        ((_ ((var expr) rest ...) body)
         ($let* _ ((var expr) rest ...) body))
        ((_ label ((var expr) rest ...) body)
         (lambda(label)
           (let-values (((r var s1) (expr label)))
             (if (eqv? r 'success)
                 (($let* (rest ...) body) s1)
                 (values r var label)))))))

    (define ($order p . ps)
      (if (null? ps)
          p
          ($let* ((x p)
                  (xs (apply $order ps)))
            ($return xs))))

    (define ($select p . ps)
      (if (null? ps)
          p
          (lambda(s)
            (let-values (((r v s1)(p s)))
              (case r
                ((success) (values 'success v s1))
                ((expect)  ((apply $select ps) s))
                ((unexpect) (values r v s)))))))

    (define ($split-by p sp)
      (lambda(s)
        (let loop ((s1 s)
                   (result '()))
          (let-values (((r v s2) (p s1)))
            (if (not (eqv? r 'success))
                (values r v s)
                (let-values (((r2 v2 s3) (sp s2)))
                  (if (not (eqv? r2 'success))
                      (values 'success (reverse (cons v result)) s2)
                      (loop s3 (cons v result)))))))))

    (define $optional
      (case-lambda
       ((p fallback)
        ($select p ($return fallback)))
       ((p)
        ($optional p #f))))
    ))

sample.scm

(import (scheme base)
        (scheme write)
        (casl parser))

(define seq (open-input-string
"; 出典 : 試験で使用する情報技術に関する用語・プログラム言語など
; https://www.jitec.ipa.go.jp/1_13download/shiken_yougo_ver2_2.pdf
;
COUNT1  START                ;
;        入力  GR1:検索する語 
;        処理  GR1中の'1'のビットの個数を求める
;        出力  GR0:GR1中の'1'のビットの個数
         PUSH  0,GR1          ; 
         PUSH  0,GR2          ;
         SUBA  GR2,GR2        ; Count = 0
         AND   GR1,GR1        ; 全部のビットが'0'?
         JZE   RETURN         ; 全部のビットが'0'なら終了
MORE     LAD   GR2,1,GR2      ; Count = Count + 1
         LAD   GR0,-1,GR1     ; 最下位の'1'のビット1個を
         AND   GR1,GR0        ;   '0'に変える
         JNZ   MORE           ; '1'のビットが残っていれば繰返し
RETURN   LD    GR0,GR2        ; GR0 = Count
         POP   GR2            ; 
         POP   GR1            ;
         RET                  ; 呼出しプログラムへ戻る
         END                  ;
"))

(for-each (lambda(x)(write x)(newline)) (casl-parse seq))