; for turbak's "design concepts in programming languages
; only closed postfix expressions for now: (postfix 0 ...)
(define (post0 . rest)
  (define (selstack st)
    (if (< (length st) 3) (error "stack empty"))
    (if (not (number? (car st))) (error "not a number"))
    `(,(if (= (car st) 0) (cadr st) (caddr st)) ,@(cdddr st)))
  (define (ngetstack st)
    (if (< (length st) 2) (error "stack empty"))
    (if (not (number? (car st))) (error "not a number"))
    (if (< (car st) 1) (error "indices start at 1"))
    (cons (list-ref (cdr st) (- (car st) 1)) (cdr st)))
  (define (needs2 st) (if (< (length st) 2) (error "stack empty")))
  (define (swapstack st) (needs2 st) `(,(cadr st) ,(car st) ,@(cddr st)))
  (define (popstack st) (if (null? st) (error "empty stack")) (cdr st))
  (define (mkstackrelop op)
    (lambda (st) (needs2 st) (if (op (car st) (cadr st)) 1 0)))
  (define (mkstacknumop2 op)
    (lambda (st)
      (needs2 st)
      (if (not (and (number? (car st)) (number? (cadr st))))
        (error "not a number"))
      `(,(op (cadr st) (car st)) ,@(cddr st))))
  (set! addstack (mkstacknumop2 +))
  (set! substack (mkstacknumop2 -))
  (set! mulstack (mkstacknumop2 *))
  (set! divstack (mkstacknumop2 /))
  (set! remstack (mkstacknumop2 (lambda (a b) (modulo a b))))
  (set! eqstack (mkstackrelop eq?))
  (set! ltstack (mkstackrelop <))
  (set! gtstack (mkstackrelop >))
  (define (process cmds s)
    (print "process" cmds "|" s)
    (if (null? cmds)
      s
      (let ((cmd (car cmds)) (rcmds (cdr cmds)))
        (if (eq? cmd 'exec)
          (begin
            (if (not (pair? (car s))) (error "not a command" (car s)))
            (apply process (append (car s) rcmds) (list (cdr s))))
          (process
            rcmds
            (cond ((number? cmd) (cons cmd s))
                  ((pair? cmd) (cons cmd s))
                  ((eq? 'swap cmd) (swapstack s))
                  ((eq? 'pop cmd) (popstack s))
                  ((eq? 'sel cmd) (selstack s))
                  ((eq? 'nget cmd) (ngetstack s))
                  ((eq? 'add cmd) (addstack s))
                  ((eq? 'mul cmd) (mulstack s))
                  ((eq? 'div cmd) (divstack s))
                  ((eq? 'sub cmd) (substack s))
                  ((eq? 'rem cmd) (remstack s))
                  ((eq? '= cmd) (eqstack s))
                  ((eq? '< cmd) (ltstack s))
                  ((eq? '> cmd) (gtstack s))
                  (else (error "unknow command" cmd))))))))
  (process rest '()))

; turbak's postfix numargs body
(define (postfix n . body)
	(lambda (l)
		(if (not (= (length l) n)) (error "number of args != " n))
		(let ((lb `(,@l ,@body)))
		(apply post0 lb))))

; (post0 (list 7 'swap 'exec) (list 0 'swap 'sub) 'swap 'exec)
(define test2 (postfix 2 (list (list 'mul 'sub) (list 1 'nget 'mul) 4 'nget 'swap 'exec 'swap 'exec)))
(test2 (list -10 2))

; (post0 (list 1 'nget 'exec) 1 'nget 'exec)

; for turbak's "design concepts in programming languages
; only closed postfix expressions for now: (postfix 0 ...)
(define (post0 . rest)
  (define (selstack st)
    (if (< (length st) 3) (error "stack empty"))
    (if (not (number? (car st))) (error "not a number"))
    `(,(if (= (car st) 0) (cadr st) (caddr st)) ,@(cdddr st)))
  (define (ngetstack st)
    (if (< (length st) 2) (error "stack empty"))
    (if (not (number? (car st))) (error "not a number"))
    (if (< (car st) 1) (error "indices start at 1"))
    (cons (list-ref (cdr st) (- (car st) 1)) (cdr st)))
  (define (needs2 st) (if (< (length st) 2) (error "stack empty")))
  (define (swapstack st) (needs2 st) `(,(cadr st) ,(car st) ,@(cddr st)))
  (define (popstack st) (if (null? st) (error "empty stack")) (cdr st))
  (define (mkstackrelop op)
    (lambda (st) (needs2 st) (if (op (car st) (cadr st)) 1 0)))
  (define (mkstacknumop2 op)
    (lambda (st)
      (needs2 st)
      (if (not (and (number? (car st)) (number? (cadr st))))
        (error "not a number"))
      `(,(op (cadr st) (car st)) ,@(cddr st))))
  (set! addstack (mkstacknumop2 +))
  (set! substack (mkstacknumop2 -))
  (set! mulstack (mkstacknumop2 *))
  (set! divstack (mkstacknumop2 /))
  (set! remstack (mkstacknumop2 (lambda (a b) (modulo a b))))
  (set! eqstack (mkstackrelop eq?))
  (set! ltstack (mkstackrelop <))
  (set! gtstack (mkstackrelop >))
  (define (process cmds s)
    (print "process" cmds "|" s)
    (if (null? cmds)
      s
      (let ((cmd (car cmds)) (rcmds (cdr cmds)))
        (if (eq? cmd 'exec)
          (begin
            (if (not (pair? (car s))) (error "not a command" (car s)))
            (apply process (append (car s) rcmds) (list (cdr s))))
          (process
            rcmds
            (cond ((number? cmd) (cons cmd s))
                  ((pair? cmd) (cons cmd s))
                  ((eq? 'swap cmd) (swapstack s))
                  ((eq? 'pop cmd) (popstack s))
                  ((eq? 'sel cmd) (selstack s))
                  ((eq? 'nget cmd) (ngetstack s))
                  ((eq? 'add cmd) (addstack s))
                  ((eq? 'mul cmd) (mulstack s))
                  ((eq? 'div cmd) (divstack s))
                  ((eq? 'sub cmd) (substack s))
                  ((eq? 'rem cmd) (remstack s))
                  ((eq? '= cmd) (eqstack s))
                  ((eq? '< cmd) (ltstack s))
                  ((eq? '> cmd) (gtstack s))
                  (else (error "unknow command" cmd))))))))
  (process rest '()))

; turbak's postfix numargs body
(define (postfix n . body)
	(lambda (l)
		(if (not (= (length l) n)) (error "number of args != " n))
		(let ((lb (apply append (list l body))))
		   (apply post0 lb))))

(define test2 (postfix 2 (list 'mul 'sub) (list 1 'nget 'mul) 4 'nget 'swap 'exec 'swap 'exec))
(test2 (list 2 -10))

; turbak is wrong in claiming that postfix cannot
; have infinite loops:
; (post0 (list 1 'nget 'exec) 1 'nget 'exec)