/usr/share/scheme48-1.9/env/jar-assem.scm is in scheme48 1.9-5.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
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 134 135 136 137 | ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
; Part of Scheme 48 1.9. See file COPYING for notices and license.
; Authors: Richard Kelsey, Jonathan Rees, Mike Sperber
; 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 (assertion-violation 'assemble "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
(assertion-violation 'assemble-instruction
"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
(assertion-violation 'assemble-instruction-with-index
"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)
(assertion-violation 'assemble-operands
"unknown stored object type" operand)))
((byte nargs) operand)
(else (assertion-violation 'assemble-operands "unknown operand type"
operand arg-spec))))
operands
arg-specs))
|