File: jar-assem.scm

package info (click to toggle)
scsh 0.5.1-2
  • links: PTS
  • area: non-free
  • in suites: potato, slink
  • size: 6,540 kB
  • ctags: 8,656
  • sloc: lisp: 39,346; ansic: 13,466; sh: 1,669; makefile: 624
file content (133 lines) | stat: -rw-r--r-- 3,843 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.


; This is file assem.scm.

;;;; Assembler

; Courtesy John Ramsdell.

; LAP syntax is much like that of the output of the disassembler except
; that global and set-global! take a symbol as an argument, 
; statements may be labeled, and jump, jump-if-false, and make-cont 
; may make a forward reference to a label to give an offset.
;
; Example: a translation of (define (dog) (if x 0 1)).
; (define dog
;   (lap dog
;     (check-nargs= 0)
;     (global x)
;     (jump-if-false 8)
;     (literal '0)
;   8 (jump out)
;     (literal '1)
; out (return)))

(define-compilator '(lap syntax)
  (let ((op/closure (enum op closure)))
    (lambda (node cenv depth cont)
      (let ((exp (node-form node)))
	(deliver-value
	 (instruction-with-template op/closure
				    (compile-lap (cddr exp) cenv)
				    (cadr exp))
	 cont)))))

; Assembler label environments are simply a-lists.
(define assembler-empty-env '())
(define (assembler-extend sym val env) (cons (cons sym val) env))
(define (assembler-lookup sym env)
  (let ((val (assv sym env)))
    (if (pair? val) (cdr val) #f)))

(define (compile-lap instruction-list cenv)
  (assemble instruction-list
	    assembler-empty-env
	    cenv))

; ASSEMBLE returns a segment.

(define (assemble instruction-list lenv cenv)
  (if (null? instruction-list)
      (sequentially)
      (let ((instr (car instruction-list))
	    (instruction-list (cdr instruction-list)))
	(cond ((pair? instr)		; Instruction
	       (sequentially
		(assemble-instruction instr lenv cenv)
		(assemble instruction-list
			  lenv
			  cenv)))
	      ((or (symbol? instr)	; Label
		   (number? instr))
	       (let ((label (make-label)))
		 (attach-label
		  label
		  (assemble instruction-list
			    (assembler-extend instr label lenv)
			    cenv))))
	      (else (error "invalid instruction" instr))))))

; ASSEMBLE-INSTRUCTION returns a segment.

(define (assemble-instruction instr lenv cenv)
  (let* ((opcode (name->enumerand (car instr) op))
	 (arg-specs (vector-ref opcode-arg-specs opcode)))
    (cond ((or (not (pair? arg-specs))
	       (not (pair? (cdr instr))))
	   (instruction opcode))
	  ((eq? (car arg-specs) 'index)
	   (assemble-instruction-with-index opcode arg-specs (cdr instr) cenv))
	  ((eq? (car arg-specs) 'offset)
	   (let ((operand (cadr instr)))
	     (apply instruction-using-label
		    opcode
		    (let ((probe (assembler-lookup operand lenv)))
		      (if probe
			  probe
			  (begin
			    (syntax-error "can't find forward label reference"
					  operand)
			    empty-segment)))
		    (assemble-operands (cddr instr) arg-specs))))
	  (else
	   (apply instruction
		  opcode
		  (assemble-operands (cdr instr) arg-specs))))))

; <index> ::= (quote <datum>) | (lap <name> <instr>) | <name>

(define (assemble-instruction-with-index opcode arg-specs operands cenv)
  (let ((operand (car operands)))
    (if (pair? operand)
	(case (car operand)
	  ((quote)
	   (instruction-with-literal opcode
				     (cadr operand)))
	  ((lap)
	   (instruction-with-template opcode
				      (compile-lap (cddr operand))
				      (cadr operand)))
	  (else
	   (syntax-error "invalid index operand" operand)
	   empty-segment))
	;; Top-level variable reference
	(instruction-with-location
	 opcode
	 (get-location (lookup cenv operand)
		       cenv
		       operand
		       value-type)))))

(define (assemble-operands operands arg-specs)
  (map (lambda (operand arg-spec)
	 (case arg-spec
	   ((stob) (or (name->enumerand operand stob)
		       (error "unknown stored object type" operand)))
	   ((byte nargs) operand)
	   (else (error "unknown operand type" operand arg-spec))))
       operands
       arg-specs))

(define byte-limit (expt 2 bits-used-per-byte))