home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / nexttsrc.lha / nexttsources / sources / comp / assembler / lap.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  5.4 KB  |  136 lines
  1. (herald (tas lap t 0))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26. ;;; Define a lap environment                
  27.  
  28. (define (new-lap-env machine parent lap-env-name)
  29.   (let ((lap-env (make-locale parent lap-env-name)))
  30.     ;(*define standard-env lap-env-name lap-env)  ; debugging only
  31.     (*define parent lap-env-name lap-env)
  32.     (set (machine-lap-env machine) lap-env)))
  33.  
  34. (define (*define-lap machine symbol value)
  35.     (*define (machine-lap-env machine) symbol value))
  36.  
  37. ;;; Pseudo-op definition
  38.  
  39. ;;; (see also AS_SYNTAX)
  40.  
  41. (define (get-pseudo key alist)
  42.     (cond ((assq key alist) => cdr)
  43.           (else nil)))
  44.     
  45. ;;; Lap processor.
  46.  
  47. ;;; For testing lap
  48.  
  49. (lset *lap-reorders-blocks?* nil)
  50.  
  51. (define (test-lap items machine)
  52.   (bind ((*current-assembly-labels* (make-labels-table 'lap-labels)))
  53.     (emit-tag (generate-symbol 'lap-entry))
  54.     (process-lap-list items machine)
  55.     (table-entry *current-assembly-labels* '&&all&&)))
  56.                  
  57. ;;; Walk the lap items, noting labels, and filling in jumps.
  58.  
  59. ;;; Needed error checking:  emit-tag on existant tag, emits after emit-jump
  60. ;;; emit-jump after emit-jump.
  61.  
  62. (define (process-lap-list items machine)
  63.   (let ((lap-env (machine-lap-env machine))
  64.         (p-ops   (machine-pseudo-ops machine))
  65.         (p-opnds (machine-pseudo-operands machine)))
  66.     (do ((items items (cdr items)))
  67.         ((null? items) '*)
  68.       (let ((i (car items)))
  69.         (bind ((*current-lap-item* i))
  70.           (cond ((pair? i)      ; --instruction
  71.                  (let ((fg (process-lap-item i lap-env p-ops p-opnds)))
  72.                    (if (fg? fg) (emit-to-ib *current-ib* fg))))
  73.  
  74.                 ((string? i)     ; --comment
  75.                  (emit-comment-to-ib *current-ib* i))
  76.   
  77.                 ((symbol? i)     ; --tag
  78.                  (let ((prev *current-ib*))
  79.                    (emit-tag i)
  80.                    (cond (*lap-reorders-blocks?*
  81.                           (if (empty? (ib-jump-op prev))
  82.                               (emit-jump-to-ib prev jump-op/jabs *current-ib* nil)))
  83.                          (else
  84.                           (maybe-set-ib-follower prev *current-ib*)))))
  85.                 (else
  86.                  (lap-error "cannot process item of this type"))))))))
  87.  
  88. ;;; Process the "operands", then apply the "instruction"
  89. ;;; maker to the result.                                       
  90.  
  91. (define (process-lap-item item lap-env p-ops p-opnds)
  92.   (destructure (((proc-exp . arg-exps) item))
  93.     (cond ((get-pseudo (car item) p-ops)
  94.            => (lambda (p) (p item)))
  95.           (else
  96.            (let ((args (map (lambda (a) (process-lap-operand a lap-env p-opnds)) 
  97.                             arg-exps)))
  98.              (apply (*value lap-env proc-exp) args)
  99.              )))))
  100.                               
  101. (define (process-lap-operand opd lap-env p-operands)
  102.     (let ((opd (process-lap-operand-1 opd lap-env p-operands)))
  103.       (cond ((fixnum? opd) (vref *register-fgs* opd))
  104.             ((and (pair? opd) (eq? (car opd) *as-number-marker*))
  105.              (cdr opd))
  106.             (else opd))))
  107.    
  108. ;;; For operands, essentially, just evaluate the form in
  109. ;;; the lap-env, except that numbers are registers, and combinations
  110. ;;; beginning with the symbol LABEL are handled specially.
  111.  
  112. (define (process-lap-operand-1 opd lap-env p-operands)
  113.     (cond ((symbol? opd)           ; speed hack to eval symbols
  114.            (*value lap-env opd))
  115.           ((and (pair? opd) (get-pseudo (car opd) p-operands))
  116.            => (lambda (p) (p opd)))
  117.           (else
  118.            (eval opd lap-env))))
  119.  
  120. ;;; To get an operand which is a number, and not translated to a register
  121. ;;; To be able to use a (NUMBER x) operand in lap, say
  122. ;;;     (*define-lap <machine> 'number make-as-number)
  123.  
  124. (define-constant *as-number-marker* (cons '*as-number-marker* nil))
  125.  
  126. (define (make-as-number n) (cons *as-number-marker* n))
  127.  
  128. ;;; Error reporting
  129.  
  130. (lset *current-lap-item* nil)
  131.                          
  132. (define (lap-error cstring . args)
  133.     (apply error 
  134.            `("in lap item ~s~%   " ,cstring) 
  135.            *current-lap-item* args))
  136.