fifol simulator

(define fifo '())

(define (fifol p)
  (set! fifo '())
  (cl p (lambda (x) 'ok)))

(define (cl p exit-loop)
(define (ex op exit-loop)
(define (bool p) (if p 'true 'false))
(newline) (display fifo) (display op)
  (cond ((number? op) (set! fifo (append fifo (list op))))
        ((eq? op 'true) (set! fifo (append fifo (list op))))
        ((eq? op 'false) (set! fifo (append fifo (list op))))
        ((and (pair? op) (eq? (car op) 'proc))
         (set! fifo (append fifo (list op))))
        (else
          (case op
            ((pop) (set! fifo (cdr fifo)))
            ((dup) (let* ((i0 (car fifo)))
               (set! fifo (append (cdr fifo) (list i0 i0)))))
            ((exch) (let* ((i0 (car fifo)) (i1 (cadr fifo)))
               (set! fifo (append (cddr fifo) (list i1 i0)))))
            ((rot) (let* ((i0 (car fifo)))
               (set! fifo (append (cdr fifo) (list i0)))))
            ((rotate) (let* ((i0 (car fifo)))
               (set! fifo (append (cdr fifo) (list i0)))))
            ((newfifo) (set! fifo (append fifo (list '()))))
            ((fifopush) (let* ((i0 (car fifo)) (i1 (cadr fifo)))
               (if (or (pair? i0) (null? i0))
                 (set! fifo (append (cddr fifo) (list (append i0 (list i1)))))
                   (exit-loop "not a fifo"))))
            ((fifopop) (let* ((i0 (car fifo)))
               (if (pair? i0)
                   (set! fifo (append (cdr fifo) (list (cdr i0) (car i0))))
                   (exit-loop "not a fifo"))))
            ((switch) (let* ((i0 (car fifo)))
               (if (pair? i0)
                   (set! fifo (append i0 (list (cadr fifo))))
                   (begin (newline) (display "not a fifo")))))
            ((add) (let* ((i0 (car fifo)) (i1 (cadr fifo)))
               (set! fifo (append (cddr fifo) (list (+ i0 i1))))))
            ((sub) (let* ((i0 (car fifo)) (i1 (cadr fifo)))
               (set! fifo (append (cddr fifo) (list (- i0 i1))))))
            ((mul) (let* ((i0 (car fifo)) (i1 (cadr fifo)))
               (set! fifo (append (cddr fifo) (list (* i0 i1))))))
            ((div) (let* ((i0 (car fifo)) (i1 (cadr fifo)))
               (set! fifo (append (cddr fifo) (list (quotient i0 i1))))))
            ((mod) (let* ((i0 (car fifo)) (i1 (cadr fifo)))
               (set! fifo (append (cddr fifo) (list (modulo i0 i1))))))
            ((abs) (let* ((i0 (car fifo)))
               (set! fifo (append (cdr fifo) (list (abs i0))))))
            ((neg) (let* ((i0 (car fifo)))
               (set! fifo (append (cdr fifo) (list (- i0))))))
            ((eq) (let* ((i0 (car fifo)) (i1 (cadr fifo)))
               (set! fifo (append (cddr fifo) 
                 (list (bool (and (number? i0) (number? i1) (= i0 i1))))))))
            ((ne) (let* ((i0 (car fifo)) (i1 (cadr fifo)))
               (set! fifo (append (cddr fifo) 
                 (list (bool (and (number? i0) (number? i1)
                   (not (= i0 i1)))))))))
            ((ge) (let* ((i0 (car fifo)) (i1 (cadr fifo)))
               (set! fifo (append (cddr fifo)
                 (list (bool (and (number? i0) (number? i1) (>= i0 i1))))))))
            ((gt) (let* ((i0 (car fifo)) (i1 (cadr fifo)))
               (set! fifo (append (cddr fifo)
                 (list (bool (and (number? i0) (number? i1) (> i0 i1))))))))
            ((le) (let* ((i0 (car fifo)) (i1 (cadr fifo)))
               (set! fifo (append (cddr fifo) 
                 (list (bool (and (number? i0) (number? i1) (<= i0 i1))))))))
            ((lt) (let* ((i0 (car fifo)) (i1 (cadr fifo)))
               (set! fifo (append (cddr fifo)
                 (list (bool (and (number? i0) (number? i1) (< i0 i1))))))))
            ((and) (let* ((i0 (car fifo)) (i1 (cadr fifo)))
               (set! fifo (append (cddr fifo) 
                 (list (cond ((and (symbol? i0) (symbol? i1))
                              (if (eq? i0 'true) i1 'false))
                             ((and (fix:fixnum? i0) (fix:fixnum? i1))
                              (fix:and i0 i1))))))))
            ((or) (let* ((i0 (car fifo)) (i1 (cadr fifo)))
               (set! fifo (append (cddr fifo) 
                 (list (cond ((and (symbol? i0) (symbol? i1))
                              (if (eq? i0 'false) i1 'true))
                             ((and (fix:fixnum? i0) (fix:fixnum? i1))
                              (fix:or i0 i1))))))))
            ((xor) (let* ((i0 (car fifo)) (i1 (cadr fifo)))
               (set! fifo (append (cddr fifo) 
                 (list (cond ((and (symbol? i0) (symbol? i1))
                              (if (eq? i0 i1) 'false 'true))
                             ((and (fix:fixnum? i0) (fix:fixnum? i1))
                              (fix:xor i0 i1))))))))
            ((not) (let* ((i0 (car fifo)))
               (set! fifo (append (cdr fifo) 
                 (list (cond ((symbol? i0)
                              (if (eq? i0 'true) 'false 'true))
                             ((fix:fixnum? i0)
                              (fix:not i0))))))))
            ((if) (let* ((i0 (car fifo)) (i1 (cadr fifo)))
               (set! fifo (cddr fifo)) 
               (if (eq? i0 'true) (cl (cdr i1) exit-loop))))
            ((ifelse) (let* ((i0 (car fifo)) (i1 (cadr fifo)) 
                             (i2 (caddr fifo)))
               (set! fifo (cdddr fifo))
               (if (eq? i0 'true) (cl (cdr i1) exit-loop)
                                  (cl (cdr i2) exit-loop))))
            ((loop) (let* ((i0 (car fifo)))
              (define (iter i exit-loop) (cl i exit-loop) (iter i exit-loop))
              (set! fifo (cdr fifo))
              (call-with-current-continuation
                (lambda (exit-loop)  (iter (cdr i0) exit-loop)))))
            ((exit) (exit-loop 'ok))
            ((=) (let* ((i0 (car fifo)))
              (set! fifo (cdr fifo)) (newline) (display i0)))
            ((fifo) (newline) (display fifo))
            (else (newline) (display 'error))))))

(define (cl-iter p exit-loop)
   (if (pair? p) (begin (ex (car p) exit-loop) (cl-iter (cdr p) exit-loop))
   'ok))

(cl-iter p exit-loop))

;examples
;ex1: print integer from 0 to 9
; (fifol '((proc dup 10 rotate ge (proc exit) rotate if dup = 1 add) 0 loop))

;ex2: print prime numbers less than 20
; (fifol '((proc 20 dup lt (proc pop exit) rot if
;     (proc dup dup exch dup rot exch mul exch lt (proc pop dup = exit)
;      exch if dup dup rot exch mod 0 exch eq (proc rot pop exit) exch if
;      1 rot add)
;    rot 2 loop 1 add)
;  2 loop))

;ex3: print the contents of fifo in reverse order
; (fifol '(newfifo 0 fifopush 1 fifopush 2 fifopush 3 fifopush -1 fifopush
; (proc fifopop rot dup -1 exch eq (proc exit) exch if 
;  (proc fifopop exch dup -1 exch rot eq (proc exit)
;   exch rot if fifopush rot)
;  rot rot loop rot = rot fifopush)
; rot loop pop pop))

;ex4: sqrt 
;(fifol '((proc dup dup dup exch div rot exch add 2 exch div exch
;dup rot exch eq (proc pop = exit) exch if exch) 1 10000000 loop))


end