状態遷移2

「C'」とかのクォートが後ろについたシンボルを実現するためだけにリードマクロ(#[])を書くのはやっぱりやりすぎだった。素直に|C'|と書こう。

INTERP> (def-transitions secd-1 "secd machine sample 2."
          ;; initial state -> transformed state
          ( s e (:NIL . c) d                         -> (nil . s) e c d )
          ( s e (:LDC x . c) d                       -> (x . s) e c d )
          ( s e (:LD (m . n) . c) d                  -> (x . s) e c d where x = (locate m n e) )
          ( s e (:LDF |c'| . c) d                    -> ((|c'| . e) . s) e c d )
          ( (x . s) e (:SEL cT cF . c) d             -> s e cX (c . d) where cX = (if x cT cF) )
          ( s e (:JOIN . c) (cr . d)                 -> s e cr d )
          ( ((|c'| . |e'|) v . s) e (:AP . c) d      -> nil (v . |e'|) |c'| (s e c . d) )
          ( (a b . s) e (:CONS . c) d                -> ((a . b) . s) e c d )
          ( ((a . b) . s) e (:CAR . c) d             -> (a . s) e c d )
          ( ((a . b) . s) e (:CDR . c) d             -> (b . s) e c d )
          ( (x . z) |e'| (:RTN . |c'|) (s e c . d)   -> (x . s) e c d )
          ( (a b . s) e (:+ . c) d                   -> (x . s) e c d where x = (+ a b) )
          ( (a b . s) e (:- . c) d                   -> (x . s) e c d where x = (- a b) )
          ( (a b . s) e (:* . c) d                   -> (x . s) e c d where x = (* a b) )
          ( (a b . s) e (:= . c) d                   -> (x . s) e c d where x = (= a b) )
          ( (a b . s) e (:> . c) d                   -> (x . s) e c d where x = (> a b) )
          ( (a b . s) e (:< . c) d                   -> (x . s) e c d where x = (< a b) )
          )
SECD-1
INTERP>  (time (secd-1 's 'e (secd::compile-pass1
                             '(let ((Y (lambda (f)
                                         ((lambda (g)
                                            (f (lambda (arg) ((g g) arg))))
                                          (lambda (g)
                                            (f (lambda (arg) ((g g) arg))))))))
                               ((Y (lambda (f)
                                     (lambda (n)
                                       (if (< n 2)
                                           n
                                           (+ (f (- n 1)) (f (- n 2))))))) 27)) ()) 'd))
Evaluation took:
  3.874 seconds of real time
  3.833235 seconds of total run time (3.662237 user, 0.170998 system)
  [ Run times consist of 0.457 seconds GC time, and 3.377 seconds non-GC time. ]
  98.94% CPU
  11,818,810,291 processor cycles
  1,800,092,944 bytes consed
  
STOP
(196418 . S)

はっきりいって遅いインタプリタだけど、状態遷移と補助関数で定義されている。

メモ。scheme の #t, #f と CL の真偽値を混同しているので要修正。nil も怪しい。
locate は今は単なるCLの関数。これも注意。次に書くマクロは vm に対するマクロになる。

マクロの展開系。destructuring-bind に頼り過ぎでエラーチェックが甘い。マクロをいじってもうちょっとカッコよくしたいところだ。

(DEFUN SECD-1 (#:S1241 #:E1242 #:C1243 #:D1244)
  "secd machine sample 2."
  (IF (AND (CONSP #:C1243) (INSTRUCTION-P (CAR #:C1243)))
      (CASE (CAR #:C1243)
        (:NIL
         (DESTRUCTURING-BIND
               (S E (#:|insn1245| . C) D)
             (LIST #:S1241 #:E1242 #:C1243 #:D1244)
           (DECLARE (IGNORE #:|insn1245|))
           (LET ()
             (SECD-1 (CONS NIL S) E C D))))
        (:LDC
         (DESTRUCTURING-BIND
               (S E (#:|insn1245| X . C) D)
             (LIST #:S1241 #:E1242 #:C1243 #:D1244)
           (DECLARE (IGNORE #:|insn1245|))
           (LET ()
             (SECD-1 (CONS X S) E C D))))
        (:LD
         (DESTRUCTURING-BIND
               (S E (#:|insn1245| (M . N) . C) D)
             (LIST #:S1241 #:E1242 #:C1243 #:D1244)
           (DECLARE (IGNORE #:|insn1245|))
           (LET ((X (LOCATE M N E)))
             (SECD-1 (CONS X S) E C D))))
        (:LDF
         (DESTRUCTURING-BIND
               (S E (#:|insn1245| |c'| . C) D)
             (LIST #:S1241 #:E1242 #:C1243 #:D1244)
           (DECLARE (IGNORE #:|insn1245|))
           (LET ()
             (SECD-1 (CONS (CONS |c'| E) S) E C D))))
        (:SEL
         (DESTRUCTURING-BIND
               ((X . S) E (#:|insn1245| CT CF . C) D)
             (LIST #:S1241 #:E1242 #:C1243 #:D1244)
           (DECLARE (IGNORE #:|insn1245|))
           (LET ((CX
                  (IF X
                      CT
                      CF)))
             (SECD-1 S E CX (CONS C D)))))
        (:JOIN
         (DESTRUCTURING-BIND
               (S E (#:|insn1245| . C) (CR . D))
             (LIST #:S1241 #:E1242 #:C1243 #:D1244)
           (DECLARE (IGNORE #:|insn1245|))
           (DECLARE (IGNORE C))
           (LET ()
             (SECD-1 S E CR D))))
        (:AP
         (DESTRUCTURING-BIND
               (((|c'| . |e'|) V . S) E (#:|insn1245| . C) D)
             (LIST #:S1241 #:E1242 #:C1243 #:D1244)
           (DECLARE (IGNORE #:|insn1245|))
           (LET ()
             (SECD-1 NIL (CONS V |e'|) |c'| (CONS S (CONS E (CONS C D)))))))
        (:CONS
         (DESTRUCTURING-BIND
               ((A B . S) E (#:|insn1245| . C) D)
             (LIST #:S1241 #:E1242 #:C1243 #:D1244)
           (DECLARE (IGNORE #:|insn1245|))
           (LET ()
             (SECD-1 (CONS (CONS A B) S) E C D))))
        (:CAR
         (DESTRUCTURING-BIND
               (((A . B) . S) E (#:|insn1245| . C) D)
             (LIST #:S1241 #:E1242 #:C1243 #:D1244)
           (DECLARE (IGNORE #:|insn1245|))
           (DECLARE (IGNORE B))
           (LET ()
             (SECD-1 (CONS A S) E C D))))
        (:CDR
         (DESTRUCTURING-BIND
               (((A . B) . S) E (#:|insn1245| . C) D)
             (LIST #:S1241 #:E1242 #:C1243 #:D1244)
           (DECLARE (IGNORE #:|insn1245|))
           (DECLARE (IGNORE A))
           (LET ()
             (SECD-1 (CONS B S) E C D))))
        (:RTN
         (DESTRUCTURING-BIND
               ((X . Z) |e'| (#:|insn1245| . |c'|) (S E C . D))
             (LIST #:S1241 #:E1242 #:C1243 #:D1244)
           (DECLARE (IGNORE #:|insn1245|))
           (DECLARE (IGNORE Z))
           (DECLARE (IGNORE |e'|))
           (DECLARE (IGNORE |c'|))
           (LET ()
             (SECD-1 (CONS X S) E C D))))
        (:+
         (DESTRUCTURING-BIND
               ((A B . S) E (#:|insn1245| . C) D)
             (LIST #:S1241 #:E1242 #:C1243 #:D1244)
           (DECLARE (IGNORE #:|insn1245|))
           (LET ((X (+ A B)))
             (SECD-1 (CONS X S) E C D))))
        (:-
         (DESTRUCTURING-BIND
               ((A B . S) E (#:|insn1245| . C) D)
             (LIST #:S1241 #:E1242 #:C1243 #:D1244)
           (DECLARE (IGNORE #:|insn1245|))
           (LET ((X (- A B)))
             (SECD-1 (CONS X S) E C D))))
        (:*
         (DESTRUCTURING-BIND
               ((A B . S) E (#:|insn1245| . C) D)
             (LIST #:S1241 #:E1242 #:C1243 #:D1244)
           (DECLARE (IGNORE #:|insn1245|))
           (LET ((X (* A B)))
             (SECD-1 (CONS X S) E C D))))
        (:=
         (DESTRUCTURING-BIND
               ((A B . S) E (#:|insn1245| . C) D)
             (LIST #:S1241 #:E1242 #:C1243 #:D1244)
           (DECLARE (IGNORE #:|insn1245|))
           (LET ((X (= A B)))
             (SECD-1 (CONS X S) E C D))))
        (:>
         (DESTRUCTURING-BIND
               ((A B . S) E (#:|insn1245| . C) D)
             (LIST #:S1241 #:E1242 #:C1243 #:D1244)
           (DECLARE (IGNORE #:|insn1245|))
           (LET ((X (> A B)))
             (SECD-1 (CONS X S) E C D))))
        (:<
         (DESTRUCTURING-BIND
               ((A B . S) E (#:|insn1245| . C) D)
             (LIST #:S1241 #:E1242 #:C1243 #:D1244)
           (DECLARE (IGNORE #:|insn1245|))
           (LET ((X (< A B)))
             (SECD-1 (CONS X S) E C D)))))
      (VALUES 'STOP #:S1241)))