;;; -*- Mode:LISP; Package:SIM; Base:10; Readtable:ZL -*-

(zwei:DEFCOM com-compile-region-for-new-processor "" ()
  (let ((*features* (cons :new *features*)))
    (zwei:COMPILE-DEFUN-INTERNAL #'compile-region-for-new-processor "Compiling" "compiled."))
  zwei:DIS-NONE)

(zwei:COMMAND-STORE 'com-compile-region-for-new-processor #/c-m-h-s-d zwei:*mode-COMTAB*)

(defun compile-region-for-new-processor (form)
  (when form
    (when (or (not (eq (car form) 'defun))
	      (not (symbolp (cadr form))))
      (ferror nil "must be simple defun"))
    (let ((output (compile-defun form)))
      (putprop (cadr form) output 'hack-compiler-output)
      (zwei:kill-string (new-processor-compiler-pp output)))))

(defun new-processor-compiler-pp (form)
  (with-output-to-string (s)
    (format s "(define-asm ~s ~s" (cadr form) (caddr form))
    (dolist (inst (cdddr form))
      (cond ((consp inst)
	     (format s "~&  ~a" inst))
	    (t
	     (format s "~&~a" inst))))
    (format s "~&  )")))

(define-asm %reset-instruction-counter ()
  (alu (func instruction-counter) <- (constant 0) setl (garbage))
  (return-xct-next)
  (no-op))

(defun create-n (n)
  (do ((n n (1- n))
       (a () (push () a)))
      ((= n 0) a)))
(define-asm CREATE-N (N)
  (STORE-IMMEDIATE BOXED (ACTIVE 1))
  (IMMEDIATE-DATA (VALUE-CELL NIL))
  (ALU (ACTIVE 2) <- (ACTIVE 0) SETM (GARBAGE))
  (STORE-IMMEDIATE BOXED (ACTIVE 3))
  (IMMEDIATE-DATA (VALUE-CELL NIL))
G6731
  (OPEN (GARBAGE))
  (ALU (OPEN 0) <- (ACTIVE 2) SETM (GARBAGE))
  (STORE-IMMEDIATE BOXED (OPEN 1))
  (IMMEDIATE-DATA 0)
  (CALL-XCT-NEXT =)
  (ALU (GARBAGE) <- (GARBAGE) SETZ (GARBAGE))
  (JUMP EQUAL TRUE-BRANCH-6737)
  (JUMP ALWAYS MERGE-6738)
TRUE-BRANCH-6737
  (JUMP ALWAYS G6732)
MERGE-6738
  (OPEN (ACTIVE 1))
  (STORE-IMMEDIATE BOXED (OPEN 0))
  (IMMEDIATE-DATA (VALUE-CELL NIL))
  (ALU (OPEN 1) <- (ACTIVE 1) SETM (GARBAGE))
  (CALL-XCT-NEXT CONS)
  (ALU (GARBAGE) <- (GARBAGE) SETZ (GARBAGE))
  (ALU (ACTIVE 4) <- (ACTIVE 1) SETM (GARBAGE))
  (ALU (ACTIVE 5) <- (ACTIVE 2) L-1 NIL)
  (ALU (ACTIVE 2) <- (ACTIVE 5) SETM (GARBAGE))
  (ALU (ACTIVE 1) <- (ACTIVE 4) SETM (GARBAGE))
  (JUMP ALWAYS G6731)
G6732
  (ALU (ACTIVE 3) <- (ACTIVE 1) SETM (GARBAGE))
  (ALU (FUNC RETURN) <- (ACTIVE 3) SETM (GARBAGE))
  )

(defun iterative-div2 (l)
  (do ((l l (cddr l))
       (a () (push (car l) a)))
      ((null l) a)))

(defun run-iterative-div2 ()
  (let ((l (create-n 200.)))
    #+new (%reset-instruction-counter)
    (do ((i 300. (1- i)))
	((= i 0))
      (iterative-div2 l)
      (iterative-div2 l)
      (iterative-div2 l)
      (iterative-div2 l)))
  nil)