; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme;  -*-

; This is file rewrite.scm.

; To be called on the S48 VM source files to rename CAR -> S48:CAR, etc.

(define (rewrite filename)
  (let* ((i-name (string-append filename ".scm"))
	 (o-name (string-append filename ".out"))
	 (forms (read-file i-name)))
    (call-with-output-file o-name
      (lambda (o-port)
	(newline)
	(display "Rewriting ")
	(display i-name)
	(display " => ")
	(display o-name)
	(for-each (lambda (form)
		    (write-form (rewrite-form form) o-port))
		  forms)))))

(define (write-form form o-port)
  (pp form o-port)
  (newline o-port)
  (write-char #\.))

(define *patterns* '())

(define (rewrite-form form)
  (cond ((symbol? form)
	 (if (memq form *renamings*)
	     (s48-symbol form)
	     form))
	((pair? form)
	 (let ((probe (assq (car form) *patterns*)))
	   (if probe
	       (rewrite-form (use-pattern (cadr probe) form))
	       (cons (rewrite-form (car form))
		     (rewrite-form (cdr form))))))
	(else form)))

(define (s48-symbol sym)
  ;;(string->symbol (string-append "S48:" (symbol->string sym)))
  (lisp:intern (lisp:symbol-name sym) s48-package)
  )

(define (use-pattern pat form)
  (if (pair? pat)
      (cons (use-pattern (car pat) form)
	    (use-pattern (cdr pat) form))
      (case pat
	((-1-) (cadr form))
	((-2-) (caddr form))
	((-3-) (cadddr form))
	((-4-) (list-ref form 5))
	((-5-) (list-ref form 6))
	(else pat))))