SICP/ex-5_39-44.scm

(load "shared/util.scm")
(load "shared/sicp-compiler-lexical-addressing.scm")

;; stub for 5.44
(define (primitive-procedure? exp ct-env) #f)

(define (compile-to-file code target linkage file-name)
  (set! label-counter 0)
  (define (write-list-to-port xs port)
    (if (null? xs)
      '()
      (begin
        (display (car xs) port)
        (display "\n" port)
        (write-list-to-port (cdr xs) port))))
  (if #t ; #t means write to file; #f means don't write to file
    (let* ((compile-result (compile code (empty-compile-time-env) target linkage))
           (assembly-insts (statements compile-result))
           (port (open-output-file file-name)))
      (write-list-to-port assembly-insts port)
      (display "[")
      (display file-name)
      (display "]\n")
      (close-output-port port))
      (begin
        (display "[")
        (display file-name)
        (display "]\n"))))

(display "\nex-5.39 - lexical-addressing\n")

(define (make-address frame-number index-number)
  (list frame-number index-number))
(define (frame-number address) (car address))
(define (index-number address) (cadr address))

(define test-env '((1 2 3) (4 5 6) (7 8 9)))

(define (lexical-address-frame frame-number env)
  (cond
    ((null? env)
     (error "frame does not exist - LEXICAL-ADDRESS-FRAME" adr env))
    ((= frame-number 0) (car env))
    (else (lexical-address-frame (- frame-number 1) (cdr env)))))

(define (lexical-address-lookup adr env)
  (define (iter-frame index-number frame)
    (cond
      ((null? frame) (error "index does not exist - LEXICAL-ADDRESS-LOOKUP" adr env))
      ((and (= index-number 0) (eq? (car frame) '*unassigned*))
       (error "var not assigned - LEXICAL-ADDRESS-LOOKUP" adr env))
      ((= index-number 0) (car frame))
      (else (iter-frame (- index-number 1) (cdr frame)))))
  (let ((frame (lexical-address-frame (frame-number adr) env)))
    (iter-frame (index-number adr) frame)))

(define (lexical-address-set! adr val env)
  (define (iter-frame index-number frame)
    (cond
      ((null? frame) (error "index does not exist - LEXICAL-ADDRESS-LOOKUP" adr env))
      ((= index-number 0) (set-car! frame val))
      (else (iter-frame (- index-number 1) (cdr frame)))))
  (let ((frame (lexical-address-frame (frame-number adr) env)))
    (iter-frame (index-number adr) frame)))

(assert (lexical-address-lookup (make-address 0 0) test-env) 1)
(lexical-address-set! (make-address 0 0) 42 test-env)
(assert (lexical-address-lookup (make-address 0 0) test-env) 42)
(assert (lexical-address-lookup (make-address 2 2) test-env) 9)
(lexical-address-set! (make-address 2 2) 43 test-env)
(assert (lexical-address-lookup (make-address 2 2) test-env) 43)


(display "\nex-5.40 - compile-time-env\n")

(define (empty-compile-time-env) '())

(define (extend-compile-time-env parameters base-env)
  (cons parameters base-env))

(display "[done]\n")

(display "\nex-5.41 - find-variable\n")

(define (find-variable var env)
  (define (get-index frame current-index)
    (cond
      ((null? frame) (error "var not found -- FIND-VARIABLE"))
      ((eq? (car frame) var) current-index)
      (else (get-index (cdr frame) (+ current-index 1)))))
  (define (find-env i frames)
    (cond
      ((null? frames) 'not-found)
      ((memq var (car frames)) (cons i (car frames)))
      (else (find-env (+ i 1) (cdr frames)))))
  (let ((find-env-result (find-env 0 env)))
    (if (eq? find-env-result 'not-found)
      'not-found
      (let* ((frame-number (car find-env-result))
             (frame (cdr find-env-result))
             (index-number (get-index frame 0)))
        (make-address frame-number index-number)))))

(assert (find-variable 'c '((y z) (a b c d e) (x y)))
        (make-address 1 2))

(assert (find-variable 'x '((y z) (a b c d e) (x y)))
        (make-address 2 0))

(assert (find-variable 'w '((y z) (a b c d e) (x y)))
        'not-found)

(display "\nex-5.42 - compile-lexical-addressing\n")

(compile-to-file
  '(let ((x 3) (y 4))
    (lambda (a b c d e)
      (let ((y (* a b x))
            (z (+ c d x)))
        (set! y 3)
        (* x y z))))
  'val 'next "f-lex-adr.scm")

(display "[done]\n")


(display "\nex-5.43 - defines-to-let\n")

(define (contains-defines? body)
  (cond
    ((null? body) #f)
    ((definition? (car body)) #t)
    (else (contains-defines? (cdr body)))))

(define (defines-to-let body)
  (define (get-defines body)
    (cond
      ((null? body) '())
      ((definition? (car body)) (cons (car body) (get-defines (cdr body))))
      (else (get-defines (cdr body)))))
  (define (expression->new-expression exp)
    (if (definition? exp)
      (define->set exp)
      exp))
  (define (define->let-assignment def)
    (list (definition-variable def) '*unassigned*))
  (define (define->set def)
    (list 'set! (definition-variable def) (definition-value def)))
  (let* ((defines (get-defines body))
         (let-assignments (map define->let-assignment defines))
         (let-expression (list 'let let-assignments))
         (expressions (map expression->new-expression body)))
    (append let-expression expressions)))

(define (lambda->lambda-without-defines exp)
  (if (contains-defines? (lambda-body exp))
    (make-lambda
      (lambda-parameters exp)
      (list (defines-to-let (lambda-body exp))))
    exp))

(compile-to-file
  '(lambda (x y)
     (define z 5)
     (+ x y z))
  'val 'next "f-def-to-var.scm")

(display "[done]\n")


(display "\nex-5.44 - improved-primitive-procedure\n")

(define (primitive-procedure? exp ct-env)
  (define primitive-procedures '(= * - +))
  ; Only treate the symbol (car exp) as a primitive procedure if it is *not* in
  ; the compile-time environment.
  (let ((var-in-ct-env (find-variable (car exp) ct-env)))
    (and (pair? exp)
         (eq? var-in-ct-env 'not-found)
         (= (length exp) 3) ;; only support two args for now
         (memq (car exp) primitive-procedures)
         )))

(compile-to-file
  '(lambda (+ * a b x y)
     (+ (* a x) (* b y)))
  'val 'next "f-primitive.scm")

(display "[done]\n")