home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-385-Vol-1of3.iso / s / s48.zip / MISC / ASSEM.SCM next >
Text File  |  1992-06-18  |  4KB  |  126 lines
  1. ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
  2. ; Copyright (c) 1992 by Richard Kelsey and Jonathan Rees.  See file COPYING.
  3.  
  4.  
  5. ; This is file assem.scm.
  6.  
  7. ;;;; Assembler
  8.  
  9. ; Courtesy John Ramsdell.
  10.  
  11. ; This version is intended to be loaded into the Scheme48 system
  12. ; environment.  It makes the %lap syntax available in the user environment.
  13. ;
  14. ; %lap syntax is much like that of the output of the disassembler except
  15. ; that global and set-global! take a symbol as an argument, 
  16. ; statements may be labeled, and jump, jump-if-false, and make-cont 
  17. ; may make a forward reference to a label to give an offset.  The offset 
  18. ; may be given as a number using (+> N) syntax.
  19. ;
  20. ; Example: a translation of (define (dog) (if x 0 1)).
  21. ; (define dog
  22. ;   (%lap dog
  23. ;     (check-nargs= 0)
  24. ;     (global x)
  25. ;     (jump-if-false (+> 5))
  26. ;     (literal '0)
  27. ;     (jump out)
  28. ;     (literal '1)
  29. ; out (return)))
  30.  
  31. (define-compilator '%lap
  32.   (lambda (exp cenv depth cont)
  33.     (deliver-value
  34.      (instruction-with-template op/closure
  35.                 (compile-lap (cddr exp) cenv)
  36.                 (cadr exp))
  37.      cont)))
  38.  
  39. (define! system-package '%lap (get-special '%lap))
  40. ;(define! user-package '%lap (get-special '%lap))
  41. (export! system-package '(%lap))
  42.  
  43. ;;; Assembler label environments are simply a-lists.
  44. (define assembler-empty-env '())
  45. (define (assembler-extend sym val env) (cons (cons sym val) env))
  46. (define (assembler-lookup sym env)
  47.   (let ((val (assq sym env)))
  48.     (and (pair? val) (cdr val))))
  49.  
  50. (define (compile-lap instruction-list cenv)
  51.   (assemble (reverse instruction-list)
  52.         assembler-empty-env
  53.         (sequentially) ;empty-segment
  54.         cenv))
  55.  
  56. (define (assemble rev-instruction-list lenv after cenv)
  57.   (if (null? rev-instruction-list)
  58.       after
  59.       (let ((instr (car rev-instruction-list))
  60.         (rev-instruction-list (cdr rev-instruction-list)))
  61.     (cond ((pair? instr)        ; Instruction
  62.            (assemble rev-instruction-list
  63.              lenv
  64.              (assemble-instruction instr lenv after cenv)
  65.              cenv))
  66.           ((symbol? instr)        ; Label
  67.            (assemble rev-instruction-list
  68.              (assembler-extend instr
  69.                        (segment-size after)
  70.                        lenv)
  71.              after
  72.              cenv))
  73.           (else (error "bad instruction" instr))))))
  74.  
  75. (define (assemble-instruction instr lenv after cenv)
  76.   (sequentially
  77.    (let ((opcode (name->enumerand (car instr) op)))
  78.      (cond ((= opcode op/closure)
  79.         (instruction-with-template op/closure
  80.                        (compile-lap (cddr instr))
  81.                        (cadr instr)))
  82.        ((or (= opcode op/global) (= opcode op/set-global!))
  83.         (instruction-with-literal opcode
  84.                       (assemble-global-ref (cadr instr))))
  85.        ((and (pair? (cdr instr))
  86.          (pair? (cadr instr))
  87.          (eq? (caadr instr) 'quote))
  88.         (instruction-with-literal opcode
  89.                       (cadr (cadr instr))))
  90.        (else
  91.         (apply instruction
  92.            opcode
  93.            (assemble-operands (cdr instr)
  94.                       lenv
  95.                       (segment-size after))))))
  96.    after))
  97.  
  98. (define (assemble-operands operands lenv following)
  99.   (if (null? operands)
  100.       '()
  101.       (let ((operand (car operands))
  102.         (after (assemble-operands (cdr operands) lenv following)))
  103.     (cond ((integer? operand) (cons operand after))
  104.           ((symbol? operand)
  105.            (let ((offset (assembler-lookup operand lenv)))
  106.          (if (integer? offset)
  107.              (let ((offset (- (+ following (length after)) offset)))
  108.                (cons (quotient offset byte-limit)
  109.                  (cons (remainder offset byte-limit) after)))
  110.              (error "cannot find forward reference" operand))))
  111.           (else (error "unknown operand type" operand))))))
  112.  
  113. ;  +> isn't a good R4RS symbol.
  114. ;        ((eq? (car operand) '+>)         ; offset
  115. ;         (let ((offset (cadr operand)))
  116. ;           (cons (quotient offset byte-limit)
  117. ;          (cons (remainder offset byte-limit) after))))
  118.  
  119. (define (assemble-global-ref exp cenv)
  120.   (if (symbol? exp)
  121.       (let ((den (clookup-variable cenv exp)))
  122.     (if (location? den)
  123.         den
  124.         (error "%lap: invalid variable reference" exp)))
  125.       (error "invalid variable name" exp)))
  126.