From 90bd09efc1ff2bd9b452e44f9fd3922ab0d32286 Mon Sep 17 00:00:00 2001
From: Felix Martin <mail@felixm.de>
Date: Sat, 1 May 2021 15:05:10 -0400
Subject: [PATCH] Implement 5.47

---
 ex-5_45-xx.scm                  | 112 +++++++++++++++++++++++++-------
 shared/sicp-eceval-compiler.scm |   2 +-
 2 files changed, 90 insertions(+), 24 deletions(-)

diff --git a/ex-5_45-xx.scm b/ex-5_45-xx.scm
index c2508b2..281c69a 100644
--- a/ex-5_45-xx.scm
+++ b/ex-5_45-xx.scm
@@ -60,36 +60,102 @@
 
 (display "[done]\n")
 
-(display "\nex-5.47\n")
+(display "\nex-5.47 - call-interpreted-from-compiled\n")
 
-; Exercise 5.47.  This section described how to modify the explicit-control
-; evaluator so that interpreted code can call compiled procedures. Show how to
-; modify the compiler so that compiled procedures can call not only primitive
-; procedures and compiled procedures, but interpreted procedures as well. This
-; requires modifying compile-procedure-call to handle the case of compound
-; (interpreted) procedures. Be sure to handle all the same target and linkage
-; combinations as in compile-proc-appl. To do the actual procedure application,
-; the code needs to jump to the evaluator's compound-apply entry point. This
-; label cannot be directly referenced in object code (since the assembler
-; requires that all labels referenced by the code it is assembling be defined
-; there), so we will add a register called compapp to the evaluator machine to
-; hold this entry point, and add an instruction to initialize it:
+(define (compile-procedure-call target linkage)
+  (let* ((primitive-branch (make-label 'primitive-branch))
+         (compiled-branch (make-label 'compiled-branch))
+         (interpreted-branch (make-label 'interpreted-branch))
+         (after-call (make-label 'after-call))
+         (compiled-linkage (if (eq? linkage 'next) after-call linkage))
+         (compiled-test-primitive
+           (make-instruction-sequence
+             '(proc) '()
+             `((test (op primitive-procedure?) (reg proc))
+               (branch (label ,primitive-branch)))))
+         (compiled-test-procedure
+           (make-instruction-sequence
+             '(proc) '()
+             `((test (op compiled-procedure?) (reg proc))
+               (branch (label ,compiled-branch)))))
+         (compiled-interpreted-branch
+           (append-instruction-sequences
+             interpreted-branch
+             (compile-intp-appl target compiled-linkage)))
+         (compiled-compiled-branch
+           (append-instruction-sequences
+             compiled-branch
+             (compile-proc-appl target compiled-linkage)))
+         (compiled-primitive-branch
+           (append-instruction-sequences
+             primitive-branch
+             (end-with-linkage
+               linkage
+               (make-instruction-sequence
+                 '(proc argl) (list target)
+                 `((assign ,target (op apply-primitive-procedure) (reg proc) (reg argl))))))))
+      (append-instruction-sequences
+        compiled-test-primitive
+       (append-instruction-sequences
+         compiled-test-procedure
+         (parallel-instruction-sequences
+           compiled-interpreted-branch
+           (parallel-instruction-sequences
+             compiled-compiled-branch
+             compiled-primitive-branch)))
+       after-call)))
 
-;  (assign compapp (label compound-apply))
-;  (branch (label external-entry))      ; branches if flag is set
-;read-eval-print-loop
-;  ...
+(define (compile-intp-appl target linkage)
+  (cond ((and (eq? target 'val) (not (eq? linkage 'return)))
+         (make-instruction-sequence
+           '(proc) all-regs
+           `((save continue)
+             (assign continue (label ,linkage))
+             (save continue)
+             (goto (reg compapp)))))
+        ((and (not (eq? target 'val)) (not (eq? linkage 'return)))
+         (let ((proc-return (make-label 'proc-return)))
+           (make-instruction-sequence '(proc) all-regs
+            `((save continue)
+              (assign continue (label ,proc-return))
+              (save continue)
+              (goto (reg compapp))
+              ,proc-return
+              (assign ,target (reg val))
+              (goto (label ,linkage))))))
+        ((and (eq? target 'val) (eq? linkage 'return))
+         (make-instruction-sequence
+           '(proc) all-regs
+           `((save continue)
+             (goto (reg compapp)))))
+        (else (error "unsupported target linkage -- COMPILE-INTP-APPL"
+                     (list target linkage)))))
 
-; To test your code, start by defining a procedure f that calls a procedure g.
-; Use compile-and-go to compile the definition of f and start the evaluator.
-; Now, typing at the evaluator, define g and try to call f.
+(define expression
+  '(begin
+     (define (f n)
+       (g n))
+     (define (factorial n)
+       (if (= n 1)
+         1
+         (* (factorial (- n 1)) n)))))
 
+; (compile-to-file expression 'val 'return "f-call-interpreted.scm")
+;; Requires compile-to-file from ex-5_3_31-38.scm
 
-(compile-and-go
-  '(define (f n)
-     (g n)))
+; (compile-and-go expression)
+;; To test this exercise uncomment the previous line, then:
+;; $ mit-scheme
+;; 1 ]=> (load "ex-5_45-xx")
+;; 2 ]=> (define (g n) (* n n n))
+;; 3 ]=> (f 3) ; calls interpreted 'g'
+
+(display "[done]\n")
 
 (display "\nex-5.48\n")
 
 ; (display "\nex-5.49\n")
+; (display "\nex-5.50\n")
+; (display "\nex-5.51\n")
+; (display "\nex-5.52\n")
 
diff --git a/shared/sicp-eceval-compiler.scm b/shared/sicp-eceval-compiler.scm
index 03f1340..b0d1070 100644
--- a/shared/sicp-eceval-compiler.scm
+++ b/shared/sicp-eceval-compiler.scm
@@ -56,7 +56,7 @@
     (set-register-contents! eceval 'val instructions)
     (set-register-contents! eceval 'flag true)
     (start eceval)))
-
+
 ;;**NB. To [not] monitor stack operations, comment in/[out] the line after
 ;; print-result in the machine controller below
 ;;**Also choose the desired make-stack version in regsim.scm