DataMuseum.dk

top - download

    Length: 6653 (0x19fd)
    Types: TextFile
    Names: »regsim.scm«

└─⟦a0efdde77⟧ Bits:30001252 EUUGD11 Tape, 1987 Spring Conference Helsinki
    └─ ⟦this⟧ »EUUGD11/gnu-31mar87/scheme/psets/regsim.scm« 

TextFile

;;; This is the register machine simulator
;;; file ps9-regsim.scm


;;; Magic syntax hack... DO NOT expect to understand this.  Hal doesn't, 
;;; and he wrote it!

(enable-language-features)

(define (cons* first-element . rest-elements)
  (let loop ((this-element first-element)
	     (rest-elements rest-elements))
    (if (null? rest-elements)
	this-element
	(cons this-element
	      (loop (car rest-elements)
		    (cdr rest-elements))))))

(define-macro (define-machine name . body)
  `(DEFINE ,name
     (CHECK-SYNTAX-AND-ASSEMBLE '(DEFINE-MACHINE ,name . ,body))))

(add-syntax! 'define-machine
  (macro (name . body)
  `(DEFINE ,name
     (CHECK-SYNTAX-AND-ASSEMBLE '(DEFINE-MACHINE ,name . ,body)))))

(disable-language-features)

;;; To set up a simulation:

(define (check-syntax-and-assemble machine-description)
  (define (check-for symbol structure)
    (cond ((not (pair? structure))
           (error "bad machine description format" structure))
          ((not (eq? (car structure) symbol))
           (error "bad machine description keyword"
                  (list symbol structure)))
          (else 'ok)))
  (check-for 'define-machine machine-description)
  (check-for 'registers (nth 2 machine-description))
  (check-for 'operations (nth 3 machine-description))
  (check-for 'controller (nth 4 machine-description))
  (assemble (cdr (nth 2 machine-description))
            (cdr (nth 3 machine-description))
            (cdr (nth 4 machine-description))))

(define (assemble registers operations controller)
  (let ((machine (make-new-machine)))
    (set-up-registers machine registers)
    (set-up-operations machine operations)
    (set-up-controller machine controller)
    machine))

(define (set-up-registers machine registers)
  (remote-set! machine '*registers* registers)
  (mapc (lambda (register-name)
          (remote-define machine register-name 
                         (make-register register-name)))
        registers))

(define (make-register name) 
  (cons nil name))

(define fetch car)

(define (set-up-operations machine operations)
  (remote-set! machine '*instruction-map*
    (mapcar (lambda (operation)
              (cons operation
                    (make-machine-instruction machine
                                              operation)))
            operations)))

(define (set-up-controller machine controller)
  (define (build-instruction-list op-list)
    (if (null? op-list)
        '()
        (let ((rest-of-instructions
               (build-instruction-list (cdr op-list))))
          (if (symbol? (car op-list))     ; An atomic symbol
                                          ; indicates a label
              (sequence (declare-label! machine
                                        (car op-list)
                                        rest-of-instructions)
                        rest-of-instructions)
              (cons (lookup-operation machine (car op-list))
                    rest-of-instructions)))))
  (remote-set! machine
               '*start*
               (build-instruction-list controller)))

(define (declare-label! machine label labeled-entry)
  (let ((defined-labels (remote-get machine '*labels*)))
    (if (memq label defined-labels)
        (error "Multiply defined label" label)
        (sequence
         (remote-define machine label labeled-entry)
         (remote-set! machine
                      '*labels*
                      (cons label defined-labels))))))

(define (lookup-operation machine op)
  (let ((pair (assoc op
                     (remote-get machine
                                 '*instruction-map*))))
    (if (null? pair)
        (error "Undeclared op" op)
        (cdr pair))))

(define (remote-get machine variable)
  (eval variable machine))

(define (remote-set! machine variable value)
  (eval (list 'set! variable (list 'quote value))
        machine))

(define (remote-define machine variable value)
  (eval (list 'define variable (list 'quote value))
        machine))

(define (make-machine-instruction machine op)
  (eval (list 'lambda '() op) machine))

(define (remote-fetch machine register-name)
  (car (remote-get machine register-name)))

(define (remote-assign machine register-name value)
  (set-car! (remote-get machine register-name) value))

(define (start machine)
  (eval '(sequence (goto *start*)
                   (execute-next-instruction))
        machine))

;;monitored stack

(define (make-stack)
  (define s nil)
  (define number-pushes 0)
  (define max-depth 0)
  (define (push x)
    (set! s (cons x s))
    (set! number-pushes (1+ number-pushes))
    (set! max-depth (max (length s) max-depth)))
  (define (pop)
    (let ((top (car s)))
      (set! s (cdr s))
      top))
  (define (initialize)
    (set! s nil)
    (set! number-pushes 0)
    (set! max-depth 0))
  (define (print-statistics)
    (print (list 'total-pushes: number-pushes
                 'maximum-depth: max-depth)))
  (define (dispatch message)
      (cond ((eq? message 'push) push)
            ((eq? message 'pop) (pop))
            ((eq? message 'initialize) (initialize))
            ((eq? message 'print-statistics) (print-statistics))
            (else (error "Unknown request -- STACK"
                         message))))
  dispatch)

(define (make-new-machine)
  (make-environment

   ;;routine to assign values to registers
   (define (assign register value)
     (set-car! register value)
     (normal-next-instruction))

   ;;saving and restoring registers
   (define the-stack (make-stack))

   (define (initialize-stack)
     (the-stack 'print-statistics)
     (the-stack 'initialize))
     
   (define (save reg)
     ((the-stack 'push) (fetch reg))
     (normal-next-instruction))

   (define (restore reg)
     (assign reg (the-stack 'pop)))

   ;;sequencing instructions
   (define program-counter (make-register 'program-counter))

   (define (execute-next-instruction)
     (cond ((null? (fetch program-counter)) 'done)
           (else
            ((car (fetch program-counter)))
            (execute-next-instruction))))

   (define (normal-next-instruction)
     (set-car! program-counter (cdr (fetch program-counter))))

   (define (goto new-sequence)
     (set-car! program-counter new-sequence))

   (define (branch predicate alternate-next)
     (if predicate
         (goto alternate-next)
         (normal-next-instruction)))

   ;; routine for simulating special instructions
   (define (perform op)
     (normal-next-instruction))

   ;; special variables used by the assembler
   (define *instruction-map* nil)
   (define *labels* nil)
   (define *registers* nil)
   (define *start* nil)

   ))