sicp-ex-5.47

  
  
  
  
 ;; add a test for compound procedures.  
 (define (compile-procedure-call op target linkage compile-time-environment) 
   (let ((primitive-branch (make-label 'primitive-branch)) 
          (compiled-branch (make-label 'compiled-branch)) 
          (compound-branch (make-label 'compound-branch))        ; ** ex 5.48 
          (after-call (make-label 'after-call))) 
      (let ((comp-linkage                ; compiled and compound 
            (if (eq? linkage 'next) after-call linkage))) 
       (append-instruction-sequences 
        (make-instruction-sequence 
          '(proc) '() 
          `((test (op primitive-procedure?) (reg proc)) 
            (branch (label ,primitive-branch)) 
            (test (op compound-procedure?) (reg proc)) ; ** 5.48 
            (branch (label ,compound-branch)))) 
         (parallel-instruction-sequences 
          (parallel-instruction-sequences        ;** 
           (append-instruction-sequences 
            compiled-branch 
            (compile-proc-appl 
             op target comp-linkage compile-time-environment)) 
           (append-instruction-sequences ; compound branch.  
            compound-branch               ; compile-compound-code will call 
            (compile-compound-call       ; compound-application in the evaluator. 
             op target comp-linkage compile-time-environment))) 
          (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))))))) 
        after-call)))) 
  
  
 ; The evaluator is arranged so that at apply-dispatch,  
 ; the continuation would be at the top of the stack.  
 ; So we must save the continue before passing control 
 ; to the evaluator. 
  
  
 (define (compile-compound-call op target linkage compile-time-environment) 
   (let ((modified-regs (if (memq op safe-ops) 
                           '() 
                           all-regs))) 
    (cond ((and (eq? target 'val) (not (eq? linkage 'return))) 
           (make-instruction-sequence 
            '(proc) modified-regs 
            `((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) modified-regs 
              `((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 continue) modified-regs 
            '((save continue) 
              (goto (reg compapp))))) 
          ((and (not (eq? target 'val)) 
                (eq? linkage 'return)) 
           (error "return linkage, target not val -- COMPILE" 
                  target)))))