;;;; support.scm


(cond-expand 
  (crunch
   (begin
     (define-syntax define-syntax-rule
       (syntax-rules ()
	 ((_ (name . args) . more)
	  (define-syntax name
	    (syntax-rules ()
	      ((_ . args) . more))))))
     (define-syntax-rule (begin0 x xs ...)
       (let ((y x))
	 (begin xs ...)
	 y))
     (define-syntax-rule (print lst) (void))
     (define-syntax fx+ +)
     (define-syntax fx- -)
     (define-syntax fx* *)
     (define-syntax fx/ /)
     (define-syntax fxand bitwise-and)
     (define-syntax fxior bitwise-ior)
     (define-syntax-rule (fxxor x y) (bitwise-xor x y))
     (define-syntax fx> >)
     (define-syntax fx< <)
     (define-syntax fx>= >=)
     (define-syntax fx<= <=)
     (define-syntax fx= =)
     (define-syntax-rule (fxneg x) (- 0 x))
     (define-syntax-rule (fxshl x n) (arithmetic-shift x n))
     (define-syntax-rule (fxshr x n) (arithmetic-shift x (fxneg n)))))
  (else))

(define-syntax-rule (hi n) (fxshr n 8))
(define-syntax-rule (lo n) (fxand #xff n))
(define-syntax-rule (lohi n m) (fxior n (fxshl m 8)))
(define-syntax-rule (word n) (fxand #xffff n))
(define-syntax-rule (byte n) (fxand #xff n))

(cond-expand
  (fulltrace
   (begin
     (define (peek M a)
       (let* ((adr (word a))
	      (tmp (u8vector-ref M adr)))
	 (format (current-error-port) "[read:  ~4,'0x -> ~2,'0x]~%" adr tmp)
	 tmp))
     (define (poke! M a n)
       (let ((adr (word a))
	     (n1 (byte n)))
	 (format (current-error-port) "[write: ~4,'0x <- ~2,'0x]~%" adr n1)
	 (u8vector-set! M adr n1)))))
  (else
   (begin
     (define-syntax-rule (peek M a)
       (u8vector-ref M (word a)))
     (define-syntax-rule (poke! M a n)
       (u8vector-set! M (word a) (byte n))))))

(define-syntax-rule (defaddrmode mode code ...)
  (define (tmp) code ...))

(define-syntax-rule (defop name modes body ...)
  (define (tmp) body ...))

(define-syntax-rule (peekw M a)
  (let ((a1 a))
    (lohi (peek M a1) (peek M (+ a1 1)))))

(define-syntax-rule (pokew! M a n)
  (let ((a1 a)
	(n1 n))
    (poke! M a1 (lo n1))
    (poke! M (+ a1 1) (hi n1))))

(define-syntax-rule (or! v n)
  (set! v (fxior v n)))

(define-syntax-rule (and! v n)
  (set! v (fxand v n)))

(define-syntax-rule (xor! v n)
  (set! v (fxxor v n)))

(define-syntax incb!
  (syntax-rules ()
    ((_ n m) (set! n (byte (+ n m))))
    ((_ n) (incb! n 1))))

(define-syntax incw!
  (syntax-rules ()
    ((_ n m) (set! n (word (+ n m))))
    ((_ n) (incw! n 1))))

(define-syntax decb!
  (syntax-rules ()
    ((_ n m) (set! n (byte (- n m))))
    ((_ n) (decb! n 1))))

(define-syntax decw!
  (syntax-rules ()
    ((_ n m) (set! n (word (- n m))))
    ((_ n) (decw! n 1))))

(define-syntax-rule (nflag? n)
  (not (zero? (fxand #x80 n))))

(define-syntax-rule (zflag! P n)
  (let ((n1 (byte n)))
    (if (zero? n1)
	(or! P #x02)
	(and! P #xfd))))

(define-syntax-rule (nflag! P n)
  (let ((n1 n))
    (if (zero? (fxand n1 #x80))
	(and! P #x7f)
	(or! P #x80))))

(define-syntax-rule (sextend n)
  (fx- (fxxor (byte n) #x80) #x80))