mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-07-02 23:50:47 +02:00
Code Activity

add the sassy x86 assembler

Browse source 
* module/Makefile.am: Add language/sassy.scm. Probably EXTRA_DIST the
  dependant files, too.
* module/language/sassy.scm: New file, the sassy loader. Sassy is
  originally R5RS code that loads a number of files. I've converted that
  toplevel file to be a Guile module that *includes* the subfiles, so
  that it all gets compiled together. It's a pretty bad hack though,
  because what I should be doing is including them relative to the
  sassy.scm source location, but we don't know that at expansion time.
  Something to fix.
  really bad hack in it so that it will compile correctly -- p

* module/language/sassy/: All the sassy files and some changelog
  information. All of these files are LGPLv2.1+, so they can be included
  in Guile.

* test-suite/standalone/sassy/tests/: Add the sassy unit tests.
* test-suite/standalone/Makefile.am:
* test-suite/standalone/test-sassy: Hook the sassy unit tests up to our
  test suite.
This commit is contained in:
Andy Wingo 2009-08-13 18:48:20 +02:00
parent d785171115
commit 66ff15e2f0
479 changed files with 12853 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

4
module/Makefile.am
View file

@ -51,6 +51,7 @@ SOURCES = \
$(OOP_SOURCES) \
$(SYSTEM_SOURCES) \
$(SCRIPTS_SOURCES) \
$(SASSY_LANG_SOURCES) \
$(GHIL_LANG_SOURCES) \
$(ECMASCRIPT_LANG_SOURCES) \
$(BRAINFUCK_LANG_SOURCES)
@ -106,6 +107,9 @@ OBJCODE_LANG_SOURCES = \
VALUE_LANG_SOURCES = \
language/value/spec.scm
SASSY_LANG_SOURCES = \
language/sassy.scm
ECMASCRIPT_LANG_SOURCES = \
language/ecmascript/parse-lalr.scm \
language/ecmascript/tokenize.scm \

125
module/language/sassy.scm Normal file
View file

@ -0,0 +1,125 @@
;;; Sassy
;; Copyright (C) 2009 Free Software Foundation, Inc.
;; Copyright (C) 2005 Jonathan Kraut
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;; Contact:
;; Jonathan Kraut
;; 4130 43 ST #C2
;; Sunnyside, NY 11104
;; jak76@columbia.edu
;;; Code:
(define-module (language sassy)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-60)
#:use-module (rnrs bytevector)
#:use-module (rnrs io ports)
#:export (sassy
sassy-data-align
sassy-data-list
sassy-data-size
sassy-data-stack
sassy-entry-point
sassy-expand
sassy-heap-align
sassy-heap-size
sassy-hexdump
sassy-make-bin
sassy-make-elf
sassy-print-relocs
sassy-print-symbols
sassy-reloc-list
sassy-reloc-name
sassy-reloc-offset
sassy-reloc-patcher
sassy-reloc-section
sassy-reloc-type
sassy-reloc-value
sassy-reloc-width
sassy-symbol-exists?
sassy-symbol-name
sassy-symbol-offset
sassy-symbol-scope
sassy-symbol-section
sassy-symbol-size
sassy-symbol-table
sassy-symbol-unres
sassy-text-align
sassy-text-list
sassy-text-org
sassy-text-size
sassy-text-stack))
(define (write-byte b . port)
(put-u8 (if (null? port) (current-output-port) (car port))
b))
(define (read-byte . port)
(get-u8 (if (null? port) (current-input-port) (car port))))
(define (hash-table-ref t k . th)
(cond ((hash-ref t k))
(else (if (null? t) #f ((car th))))))
(define hash-table-set! hash-set!)
(define (alist->hash-table lst)
(let ((t (make-hash-table)))
(for-each (lambda (itm)
(hash-table-set! t (car itm) (cdr itm)))
lst)
t))
(define (hash-table-values t)
(hash-map->list (lambda (k v) v) t))
;; HACK: we know we're compiling from a certain dir, so encode like
;; this. Nasty.
(include "language/sassy/extras.scm")
(include "language/sassy/meta-lambda.scm")
(include "language/sassy/push-stacks.scm")
(include "language/sassy/api.scm")
(include "language/sassy/intern.scm")
(include "language/sassy/macros.scm")
(include "language/sassy/numbers.scm")
;; The original sassy included other/srfi-56-pieces, but we can use
;; bytevectors for that.
(define (float32->byte-list float)
(let ((bv (make-bytevector 4)))
(bytevector-ieee-single-native-set! bv 0 float)
(bytevector->u8-list bv)))
(define (float64->byte-list float)
(let ((bv (make-bytevector 8)))
(bytevector-ieee-double-native-set! bv 0 float)
(bytevector->u8-list bv)))
(include "language/sassy/operands.scm")
(include "language/sassy/text-block.scm")
(include "language/sassy/opcodes.scm")
(include "language/sassy/text.scm")
(include "language/sassy/parse.scm")
(include "language/sassy/main.scm")
(include "language/sassy/flat-bin.scm")
(include "language/sassy/elf.scm")
; (load "tests/run-tests.scm")
; (sassy-run-tests 'all)

166
module/language/sassy/api.scm Normal file
View file

@ -0,0 +1,166 @@
; api.scm - access Sassy's output
; Copyright (C) 2005 Jonathan Kraut
; This library is free software; you can redistribute it and/or
; modify it under the terms of the GNU Lesser General Public
; License as published by the Free Software Foundation; either
; version 2.1 of the License, or (at your option) any later version.
; This library is distributed in the hope that it will be useful,
; but WITHOUT ANY WARRANTY; without even the implied warranty of
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
; Lesser General Public License for more details.
; You should have received a copy of the GNU Lesser General Public
; License along with this library; if not, write to the Free Software
; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
; Contact:
; Jonathan Kraut
; 4130 43 ST #C2
; Sunnyside, NY 11104
; jak76@columbia.edu
; see file COPYING in the top of Sassy's distribution directory
; module api
; import srfi-9 push-stacks
; export all
(define-record-type sassy-output
(make-sassy-output a b c d e f g h i j k)
sassy-output?
(a sassy-symbol-table sassy-symbol-table-set!)
(b sassy-reloc-list sassy-reloc-list-set!)
(c sassy-entry-point sassy-entry-point-set!)
(d sassy-data-stack sassy-data-stack-set!)
(e sassy-text-stack sassy-text-stack-set!)
(f sassy-heap-align sassy-heap-align-set!)
(g sassy-data-align sassy-data-align-set!)
(h sassy-text-align sassy-text-align-set!)
(i sassy-heap-size sassy-heap-size-set!)
(j sassy-text-org sassy-text-org-set!)
(k sassy-bits sassy-bits-set!))
(define-record-type sassy-symbol
(make-sassy-symbol a b c d e f g)
sassy-symbol?
(a sassy-symbol-name sassy-symbol-name-set!)
(b sassy-symbol-scope sassy-symbol-scope-set!)
(c sassy-symbol-section sassy-symbol-section-set!)
(d sassy-symbol-offset sassy-symbol-offset-set!)
(e sassy-symbol-size sassy-symbol-size-set!)
(f sassy-symbol-unres sassy-symbol-unres-set!)
(g sassy-symbol-exp sassy-symbol-exp-set!))
(define-record-type sassy-reloc
(make-sassy-reloc a b c d e f g)
sassy-reloc?
(a sassy-reloc-name sassy-reloc-name-set!)
(b sassy-reloc-section sassy-reloc-section-set!)
(c sassy-reloc-offset sassy-reloc-offset-set!)
(d sassy-reloc-type sassy-reloc-type-set!)
(e sassy-reloc-patcher sassy-reloc-patcher-set!)
(f sassy-reloc-value sassy-reloc-value-set!)
(g sassy-reloc-width sassy-reloc-width-set!))
(define (sassy-data-list sassy-output)
(push-stack-items (sassy-data-stack sassy-output)))
(define (sassy-text-list sassy-output)
(push-stack-items (sassy-text-stack sassy-output)))
(define (sassy-text-size sassy-output)
(push-stack-size (sassy-text-stack sassy-output)))
(define (sassy-data-size sassy-output)
(push-stack-size (sassy-data-stack sassy-output)))
(define (sassy-symbol-exists? sassy-output name)
(hash-table-ref (sassy-symbol-table sassy-output) name (lambda () #f)))
(define (sassy-hexdump list-of-bytes)
(let ((print-count (lambda (count)
(let ((n (number->string count 16)))
(display (make-string (- 8 (string-length n)) #\0))
(display n)
(display #\space))))
(byte->azkey (lambda (byte)
(if (and (>= byte 32) (<= byte 126))
(integer->char byte)
#\.)))
(print-hex (lambda (byte)
(let ((tmp (number->string byte 16)))
(if (= 1 (string-length tmp))
(display "0"))
(display tmp)
(display #\space))))
(print-string (lambda (string)
(display "|")
(display (list->string (reverse string)))
(display "|")
(newline))))
(define string '())
(define col 1)
(newline)
(do ((rest list-of-bytes (cdr rest))
(count 0 (+ count 1)))
((null? rest)
(if (not (zero? (modulo count 16)))
(begin
(display (make-string (- 61 col) #\space))
(print-string string))))
(if (zero? (modulo count 16))
(begin (print-count count) (set! col 10)))
(if (zero? (modulo count 8))
(begin (display #\space) (set! col (+ col 1))))
(print-hex (car rest))
(set! col (+ col 3))
(set! string (cons (byte->azkey (car rest)) string))
(if (= 15 (modulo count 16))
(begin (display #\space)
(print-string string)
(set! string '()))))))
(define sassy-print-relocs #f)
(define sassy-print-symbols #f)
(let ((print-field (lambda (t v record)
(display t)
(display ": ")
(let ((t (v record)))
(display (or t "#<undefined>")))
(newline)))
(make-num (lambda (x)
(if x
(string-append "#x" (number->string x 16))
"#<undefined>"))))
(set! sassy-print-relocs
(lambda (sassy-output)
(for-each
(lambda (reloc)
(newline)
(print-field "name " sassy-reloc-name reloc)
(print-field "section" sassy-reloc-section reloc)
(print-field "offset " (lambda (x)
(make-num (sassy-reloc-offset x))) reloc)
(print-field "type " sassy-reloc-type reloc)
(print-field "value " (lambda (x)
(make-num (sassy-reloc-value x))) reloc)
(print-field "width " (lambda (x)
(make-num (sassy-reloc-width x))) reloc))
(sassy-reloc-list sassy-output))))
(set! sassy-print-symbols
(lambda (sassy-output)
(for-each
(lambda (sym)
(newline)
(print-field "name " sassy-symbol-name sym)
(print-field "scope " sassy-symbol-scope sym)
(print-field "section" sassy-symbol-section sym)
(print-field "offset " (lambda (x)
(make-num (sassy-symbol-offset x))) sym)
(print-field "size " (lambda (x)
(make-num (sassy-symbol-size x))) sym))
(hash-table-values (sassy-symbol-table sassy-output))))))

457
module/language/sassy/elf.scm Normal file
View file

@ -0,0 +1,457 @@
; elf.scm - create ELF files from Sassy's output
; Copyright (C) 2005 Jonathan Kraut
; This library is free software; you can redistribute it and/or
; modify it under the terms of the GNU Lesser General Public
; License as published by the Free Software Foundation; either
; version 2.1 of the License, or (at your option) any later version.
; This library is distributed in the hope that it will be useful,
; but WITHOUT ANY WARRANTY; without even the implied warranty of
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
; Lesser General Public License for more details.
; You should have received a copy of the GNU Lesser General Public
; License along with this library; if not, write to the Free Software
; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
; Contact:
; Jonathan Kraut
; 4130 43 ST #C2
; Sunnyside, NY 11104
; jak76@columbia.edu
; see file COPYING in the top of Sassy's distribution directory
; module elf
; import api push-stacks numbers
; export all
(define (sassy-make-elf output-file sassy-output)
; the elf constants used
(define sht-progbits 1)
(define sht-symtab 2)
(define sht-strtab 3)
(define sht-nobits 8)
(define sht-rel 9)
(define shf-write 1)
(define shf-alloc 2)
(define shf-execinstr 4)
(define stn-undef 0)
(define stb-local 0)
(define stb-global 1)
(define stt-notype 0)
(define stt-object 1)
(define stt-func 2)
(define stt-section 3)
(define shn-abs #xfff1)
(define r-386-32 1)
(define r-386-pc32 2)
(define r-386-got32 3)
(define r-386-plt32 4)
(define r-386-gotpc 10)
(define r-386-gotoff 9)
(define shn-undef 0)
; wrappers for symbols that begin with a period, since r5rs doesn't
; allow you to actually write such symbols literally
(define dot-text (string->symbol ".text"))
(define dot-data (string->symbol ".data"))
(define dot-bss (string->symbol ".bss"))
(define dot-symtab (string->symbol ".symtab"))
(define dot-shstrtab (string->symbol ".shstrtab"))
(define dot-rel-data (string->symbol ".rel.data"))
(define dot-rel-text (string->symbol ".rel.text"))
(define dot-strtab (string->symbol ".strtab"))
(define empty-symbol (string->symbol ""))
(define (symbol<=? x y)
(string<=? (symbol->string x) (symbol->string y)))
; Sort some of the things to ensure identical orders of entries regardless of the particular scheme implementation (hash-table-values)
(define (quicksort-records lst acc pred)
(if (or (null? lst) (null? (cdr lst)))
lst
(let ((p (car lst)))
(let iter ((r (cdr lst)) (l '()) (g '()))
(cond ((null? r) (append (quicksort-records l acc pred)
(cons p (quicksort-records g acc pred))))
((pred (acc (car r)) (acc p))
(iter (cdr r) (cons (car r) l) g))
(else (iter (cdr r) l (cons (car r) g))))))))
; Return a new empty elf string table. Elf string tables consists of
; \nul, followed by \nul-terminated strings.
(define (make-string-table)
(let ((table (make-pushdown-stack)))
(push-stack-push table 0)
table))
; Enter a symbol in a string-table and return its index
(define (string-table-set! table symbol)
(let ((return-ndx (push-stack-size table)))
(push-stack-push table (map char->integer
(string->list (symbol->string symbol))))
(push-stack-push table 0)
return-ndx))
; Entries-tables map symbols or section-names to their row in the
; appropriate table (sym-table or sh-table) in the image
(define (make-entries-table) (cons 0 (make-hash-table)))
(define (entry-set! entries-table symbol)
(hash-table-set! (cdr entries-table) symbol (car entries-table))
(set-car! entries-table (+ (car entries-table) 1)))
(define (entry-ref entries-table symbol)
(hash-table-ref (cdr entries-table) symbol))
(define number-of-entries car)
(let ((image (make-pushdown-stack))
(strtab (make-string-table))
(sh-strtab (make-string-table))
(e-shoff-patcher #f)
(e-shnum-patcher #f)
(e-shstrndx-patcher #f)
(sh-table (make-pushdown-stack))
(sh-table-entries (make-entries-table))
(sym-table (make-pushdown-stack))
(sym-table-entries (make-entries-table)))
; Add a section header. There should 10 fields: sh-name sh-type
; sh-flags sh-addr sh-offset sh-size sh-link sh-info sh-addralign and
; sh-entsize
(define (section-header-set! name . fields)
(for-each (lambda (field)
(push-stack-push sh-table (number->byte-list field 4)))
fields)
(entry-set! sh-table-entries name))
; Add a symbol
(define (sym-table-set! name
strtab-ndx value size info other ndx)
(for-each (lambda (field)
(push-stack-push sym-table
(number->byte-list field 4)))
(list strtab-ndx value size))
(for-each (lambda (field)
(push-stack-push sym-table field))
(list info other))
(push-stack-push sym-table (number->byte-list ndx 2))
(entry-set! sym-table-entries name))
; Add a list of symbols
(define (make-sym-entries sym-lst scope)
(for-each
(lambda (symbol)
(sym-table-set! (sassy-symbol-name symbol)
(string-table-set! strtab (sassy-symbol-name symbol))
(or (sassy-symbol-offset symbol) stn-undef)
(or (sassy-symbol-size symbol) 0)
(+ (ash scope 4)
(case (sassy-symbol-section symbol)
((data) stt-object)
((text) stt-func)
(else stt-notype)))
0
(case (sassy-symbol-section symbol)
((heap) (entry-ref sh-table-entries dot-bss))
((data) (entry-ref sh-table-entries dot-data))
((text) (entry-ref sh-table-entries dot-text))
(else shn-undef))))
sym-lst))
; Filter a list of records into two separate lists according to
; (getter field-val). Return 2 values (lists)
(define (split-list-of-records list-of-records getter field-val)
(let iter ((rest list-of-records)
(win '())
(lose '()))
(cond ((null? rest) (values win lose))
((eq? field-val (getter (car rest)))
(iter (cdr rest)
(cons (car rest) win)
lose))
(else (iter (cdr rest)
win
(cons (car rest) lose))))))
; Dispatch on the reloc type and name to push an elf-reloc on to the image
(define (push-reloc reloc)
(let ((get-reloc-name
(lambda (name)
(case (sassy-symbol-section
(hash-table-ref (sassy-symbol-table sassy-output)
name))
((text) dot-text)
((data) dot-data)
((heap) dot-bss)
(else name))))
(make-reloc-info
(lambda (name type)
(+ (if name
(ash (entry-ref sym-table-entries name) 8)
0)
(case type
((abs) r-386-32)
((rel) r-386-pc32)
((gotpc) r-386-gotpc)
((gotoff) r-386-gotoff)
((got32) r-386-got32)
((plt32) r-386-plt32))))))
(push-stack-push image (number->byte-list (sassy-reloc-offset reloc) 4))
(push-stack-push
image
(number->byte-list
(case (sassy-reloc-type reloc)
((abs)
(make-reloc-info (if (not (sassy-reloc-name reloc))
(case (sassy-reloc-section reloc)
((data) dot-data)
((text) dot-text))
; dot-text
(get-reloc-name (sassy-reloc-name reloc)))
'abs))
((rel)
((sassy-reloc-patcher reloc) -4)
(make-reloc-info (sassy-reloc-name reloc) 'rel))
((gotoff) (make-reloc-info (get-reloc-name (sassy-reloc-name reloc))
'gotoff))
((gotpc) (make-reloc-info (sassy-reloc-name reloc) 'gotpc))
((got32) (make-reloc-info (sassy-reloc-name reloc) 'got32))
((sym32) (make-reloc-info (sassy-reloc-name reloc) 'abs))
((plt32)
((sassy-reloc-patcher reloc) -4)
(make-reloc-info (sassy-reloc-name reloc) 'plt32)))
4))))
; All setup - now to start building:
; Create some null entries
(section-header-set! empty-symbol 0 0 0 0 0 0 0 0 0 0)
(sym-table-set! empty-symbol 0 0 0 0 0 0)
(sym-table-set! 'sh-null 0 0 0 stt-section stb-local shn-abs)
; Build elf-header and patchers for later, and pad it.
(push-stack-push image (list 127 69 76 70 1 1 1 0 0 0 0 0 0 0 0
0 1 0 3 0 1 0 0 0 0 0 0 0 0 0 0 0))
(set! e-shoff-patcher (push-stack-push->patcher image (list 0 0 0 0)))
(push-stack-push image (list 0 0 0 0 52 0 0 0 0 0 40 0))
(set! e-shnum-patcher
(push-stack-push->patcher image (number->byte-list 0 2)))
(set! e-shstrndx-patcher
(push-stack-push->patcher image (number->byte-list 0 2)))
(push-stack-align image 16 0)
; Handle the heap section
(if (not (zero? (sassy-heap-size sassy-output)))
(begin
(section-header-set! dot-bss
(string-table-set! sh-strtab dot-bss)
sht-nobits
(+ shf-write shf-alloc)
0
(push-stack-size image)
(sassy-heap-size sassy-output)
0
0
(sassy-heap-align sassy-output)
0)
(sym-table-set! dot-bss 0 0 0 stt-section stb-local
(entry-ref sh-table-entries dot-bss))))
; Handle the data section
(if (not (zero? (sassy-data-size sassy-output)))
(begin
(section-header-set! dot-data
(string-table-set! sh-strtab dot-data)
sht-progbits
(+ shf-write shf-alloc)
0
(push-stack-size image)
(sassy-data-size sassy-output)
0
0
(sassy-data-align sassy-output)
0)
(sym-table-set! dot-data 0 0 0 stt-section stb-local
(entry-ref sh-table-entries dot-data))
(push-stack-append! image (sassy-data-stack sassy-output))
(push-stack-align image 16 0)))
; Handle the text section
(if (not (zero? (sassy-text-size sassy-output)))
(begin
(section-header-set! dot-text
(string-table-set! sh-strtab dot-text)
sht-progbits
(+ shf-execinstr shf-alloc)
0
(push-stack-size image)
(sassy-text-size sassy-output)
0
0
(sassy-text-align sassy-output)
0)
(sym-table-set! dot-text 0 0 0 stt-section stb-local
(entry-ref sh-table-entries dot-text))
(push-stack-append! image (sassy-text-stack sassy-output))
(push-stack-align image 16 0)))
; Handle the symbol table
(call-with-values
(lambda () (split-list-of-records
(hash-table-values (sassy-symbol-table sassy-output))
sassy-symbol-scope
'local))
(lambda (locals globals)
(define last-local (number-of-entries sym-table-entries))
(make-sym-entries (quicksort-records locals sassy-symbol-name symbol<=?)
stb-local)
(set! last-local (number-of-entries sym-table-entries))
(make-sym-entries (quicksort-records globals
sassy-symbol-name
symbol<=?)
stb-global)
(section-header-set! dot-symtab
(string-table-set! sh-strtab dot-symtab)
sht-symtab
0
0
(push-stack-size image)
(push-stack-size sym-table)
;strtab up next
(+ 1 (number-of-entries sh-table-entries))
last-local
4
16)
(push-stack-append! image sym-table)
(push-stack-align image 16 0)))
; Handle strtab
(section-header-set! dot-strtab
(string-table-set! sh-strtab dot-strtab)
sht-strtab
0
0
(push-stack-size image)
(push-stack-size strtab)
0
0
1
0)
(push-stack-append! image strtab)
(push-stack-align image 16 0)
; Handle the relocations table
(call-with-values
(lambda () (split-list-of-records (sassy-reloc-list sassy-output)
sassy-reloc-section
'data))
(lambda (datas texts)
(if (not (null? datas))
(let ((current-offset (push-stack-size image)))
(for-each push-reloc (quicksort-records datas sassy-reloc-offset
<=))
(section-header-set! dot-rel-data
(string-table-set! sh-strtab dot-rel-data)
sht-rel
0
0
current-offset
(- (push-stack-size image) current-offset)
(entry-ref sh-table-entries dot-symtab)
(entry-ref sh-table-entries dot-data)
4
8)
(push-stack-align image 16 0)))
(if (not (null? texts))
(let ((current-offset (push-stack-size image)))
(for-each
(lambda (reloc)
; skip 'rel relocs in the text section unless their targets are
; symbols with an unknown offset (imported, or undefined and exported,
; like _GLOBAL_OFFSET_TABLE)
(when (not (and (eq? 'rel (sassy-reloc-type reloc))
(or (and (sassy-reloc-name reloc)
(sassy-symbol-offset
(hash-table-ref (sassy-symbol-table
sassy-output)
(sassy-reloc-name
reloc)
(lambda () #f))))
(not (sassy-reloc-name reloc)))))
(push-reloc reloc)))
(quicksort-records texts sassy-reloc-offset <=))
(section-header-set! dot-rel-text
(string-table-set! sh-strtab dot-rel-text)
sht-rel
0
0
current-offset
(- (push-stack-size image) current-offset)
(entry-ref sh-table-entries dot-symtab)
(entry-ref sh-table-entries dot-text)
4
8)
(push-stack-align image 16 0)))))
; Handle sh-strtab
(let ((index (string-table-set! sh-strtab dot-shstrtab)))
(section-header-set! dot-shstrtab
index
sht-strtab
0
0
(push-stack-size image)
(push-stack-size sh-strtab)
0
0
1
0)
(push-stack-append! image sh-strtab)
(push-stack-align image 16 0))
; Patch the elf-header
(e-shoff-patcher (number->byte-list (push-stack-size image) 4))
(e-shnum-patcher (number->byte-list (number-of-entries sh-table-entries) 2))
(e-shstrndx-patcher (number->byte-list (entry-ref sh-table-entries
dot-shstrtab)
2))
; Handle the section-header table ...
(push-stack-append! image sh-table)
; ... and A-WAY-YAY we go!!!!
(if (file-exists? output-file)
(delete-file output-file))
(with-output-to-file output-file
(lambda ()
(for-each (lambda (byte)
(write-byte byte))
(push-stack-items image))))
)) ;end sassy-make-elf

43
module/language/sassy/extras.scm Normal file
View file

@ -0,0 +1,43 @@
; extras.scm - utility procedures for Sassy
; Copyright (C) 2005 Jonathan Kraut
; This library is free software; you can redistribute it and/or
; modify it under the terms of the GNU Lesser General Public
; License as published by the Free Software Foundation; either
; version 2.1 of the License, or (at your option) any later version.
; This library is distributed in the hope that it will be useful,
; but WITHOUT ANY WARRANTY; without even the implied warranty of
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
; Lesser General Public License for more details.
; You should have received a copy of the GNU Lesser General Public
; License along with this library; if not, write to the Free Software
; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
; Contact:
; Jonathan Kraut
; 4130 43 ST #C2
; Sunnyside, NY 11104
; jak76@columbia.edu
; see file COPYING in the top of Sassy's distribution directory
;==============;
; ;
; Extras ;
; ;
;==============;
(define-syntax when
(syntax-rules ()
((_ test conseq ...) (if test (begin conseq ...)))))
(define (read-file file)
(with-input-from-file file
(lambda ()
(let iter ((next (read)))
(if (eof-object? next)
'()
(cons next (iter (read))))))))

163
module/language/sassy/flat-bin.scm Normal file
View file

@ -0,0 +1,163 @@
; flat-bin.scm - create bin files from Sassy's output
; Copyright (C) 2005 Jonathan Kraut
; This library is free software; you can redistribute it and/or
; modify it under the terms of the GNU Lesser General Public
; License as published by the Free Software Foundation; either
; version 2.1 of the License, or (at your option) any later version.
; This library is distributed in the hope that it will be useful,
; but WITHOUT ANY WARRANTY; without even the implied warranty of
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
; Lesser General Public License for more details.
; You should have received a copy of the GNU Lesser General Public
; License along with this library; if not, write to the Free Software
; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
; Contact:
; Jonathan Kraut
; 4130 43 ST #C2
; Sunnyside, NY 11104
; jak76@columbia.edu
; see file COPYING in the top of Sassy's distribution directory
; module flat-bin
; import api
; export all
; This is a good demonstration of how to use the output API, and we
; should probably include it in chapter 7 of the docs.
; usage:
; procedure:
; (sassy-make-bin output-file sassy-output opts ...) => unspecified
; Combines the text and data sections of sassy-output and writes a
; flat binary file to output-file. If the file already exists it is
; deleted. Any (org) directive is taken into account, and relocations
; are performed on absolute references in the data section. The data
; segment is placed (and aligned properly) immediately after the text
; segment.
; opts can be none, one or both of the following quoted symbols:
; 'boot : Make the file be an x86 boot-sector. That is, zero-fill the
; remainder of the file to 510 bytes, and add the x86 boot-sector
; signature #x55aa to bytes 511 and 512.
; 'stats : Display some stats about the output.
(define (sassy-make-bin output-file sassy-output . opts)
(define boot-sector? (memq 'boot opts))
(define stats? (memq 'stats opts))
(define data? (not (zero? (sassy-data-size sassy-output))))
; Grap some info for printout stats later.
(define text-size (sassy-text-size sassy-output))
(define data-size (sassy-data-size sassy-output))
(define text-pad 0)
(define (display-stat . itms)
(for-each display itms)
(newline))
(define (needed-reloc? x)
(and (eq? 'abs (sassy-reloc-type x))
(let ((name (sassy-reloc-name x)))
(if name
(let ((symbol (sassy-symbol-exists? sassy-output name)))
(and (eq? 'data (sassy-symbol-section symbol))
(not (eq? 'import (sassy-symbol-scope symbol)))))
(eq? 'data (sassy-reloc-section x))))))
; Align the end of the text-section to the align of the data section.
; The data section will begin at this point in the file.
; (nop) is used as the filler.
(when data?
(push-stack-align (sassy-text-stack sassy-output)
(sassy-data-align sassy-output)
#x90))
(set! text-pad (- (sassy-text-size sassy-output) text-size))
; Since the text-section is going to be loaded at whatever the given
; (org) was, all absolute relocations in the text section that refer
; to other locations in the text section already have the offset of
; (org) added to them, so we don't have to apply relocations to
; those. And we don't need to relocate relative addresses in the
; text section (and relative relocations aren't allowed in the data
; section).
; So, we only need to relocate references to symbols defined in the data
; section, or anonymous relocs in the data section
; Also, we need to grab all those references both from the
; text-section _and_ the _data_ section
(when data?
(let ((data-relocs-to-do
(filter needed-reloc? (sassy-reloc-list sassy-output))))
; Now we get ready to apply the relocations taking into account the new
; end of the text-section (or beginning of the data-section).
; For each reloc-to-do, we're going to apply it's patcher
; to the the data-offset plus the value already there
(let* ((text-offset (sassy-text-org sassy-output))
(data-offset (+ text-offset (sassy-text-size sassy-output))))
(for-each (lambda (reloc)
((sassy-reloc-patcher reloc)
(+ data-offset (sassy-reloc-value reloc))))
data-relocs-to-do))
; Now all we have to to is append the data to the text, mark it as
; a boot sectior, and spit it out.
; The fastest way to tack a data section on to a text section is
; the following
; !!!!NOTE: This actually alters the text section (append!)
(push-stack-append! (sassy-text-stack sassy-output)
(sassy-data-stack sassy-output))))
(when boot-sector?
; sanity check
(if (> (sassy-text-size sassy-output) 510)
(error "segment too big for a boot sector")
(begin
; mark it as a boot sector
(push-stack-align (sassy-text-stack sassy-output) 510 0)
(push-stack-push (sassy-text-stack sassy-output)
(list #x55 #xaa)))))
; dump to file
(when (file-exists? output-file)
(delete-file output-file))
(with-output-to-file output-file
(lambda ()
(for-each write-byte (sassy-text-list sassy-output))))
(when stats?
(display-stat "Text size: " text-size " bytes")
(display-stat "Data size: " data-size " bytes")
(display-stat "Data align: "
(sassy-data-align sassy-output)
" byte boundary")
(display-stat
"Total size: "
(+ text-size data-size text-pad)
" bytes, with " text-pad " bytes of padding in the text section.")
(when boot-sector?
(display-stat "Made a boot sector"))))

140
module/language/sassy/intern.scm Normal file
View file

@ -0,0 +1,140 @@
; intern.scm - private api functions for Sassy
; Copyright (C) 2005 Jonathan Kraut
; This library is free software; you can redistribute it and/or
; modify it under the terms of the GNU Lesser General Public
; License as published by the Free Software Foundation; either
; version 2.1 of the License, or (at your option) any later version.
; This library is distributed in the hope that it will be useful,
; but WITHOUT ANY WARRANTY; without even the implied warranty of
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
; Lesser General Public License for more details.
; You should have received a copy of the GNU Lesser General Public
; License along with this library; if not, write to the Free Software
; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
; Contact:
; Jonathan Kraut
; 4130 43 ST #C2
; Sunnyside, NY 11104
; jak76@columbia.edu
; see file COPYING in the top of Sassy's distribution directory
; module intern
; import api push-stacks srfi-69
; export all
; Looks up symbol-name (a scheme symbol) in the symbol-table of
; sassy-output. If no record exists for that name, it creates a fresh
; one, in the table. Then for each item in the list of field-value
; pairs, it sets the corresponding field of the sassy-symbol to the
; value (or in the case of the 'unres field, adds the value to the
; list stored there). The pairs must be proper lists. The result is
; the sassy-symbol that was modified.
; Anytime a new offset is given via the field-pair '(offset <value>),
; all the back-patchers stored in the unres field of the sassy-symbol are
; applied to the <value>.
(define (sassy-symbol-set! sassy-output symbol-name . list-of-field-pairs)
(let ((exists (sassy-symbol-exists-env? sassy-output symbol-name)))
(when (not exists)
(set! exists (make-sassy-symbol symbol-name 'local #f #f #f '() #f))
(let iter ((t (sassy-symbol-table sassy-output)))
(if (hash-table? (car t))
(hash-table-set! (car t) symbol-name exists)
(iter (cdr t)))))
(for-each
(lambda (field-pair)
(case (car field-pair)
((name) (sassy-symbol-name-set! exists (cadr field-pair)))
((scope) (sassy-symbol-scope-set! exists (cadr field-pair)))
((section) (sassy-symbol-section-set! exists (cadr field-pair)))
((size) (sassy-symbol-size-set! exists (cadr field-pair)))
((offset)
(sassy-symbol-offset-set! exists (cadr field-pair))
(for-each (lambda (back-patcher)
(back-patcher (cadr field-pair)))
(sassy-symbol-unres exists)))
((unres)
(sassy-symbol-unres-set!
exists (cons (cadr field-pair) (sassy-symbol-unres exists))))
((exp) (sassy-symbol-exp-set! exists (cadr field-pair)))))
list-of-field-pairs)
exists))
(define (sassy-symbol-exists-env? sassy-output name)
(let iter ((rst (sassy-symbol-table sassy-output)))
(cond ((hash-table? (car rst))
(hash-table-ref (car rst) name (lambda () #f)))
((eq? name (sassy-symbol-name (car rst))) (car rst))
(else (iter (cdr rst))))))
(define (sassy-symbol-defined? sassy-output name)
(let ((maybe (sassy-symbol-exists-env? sassy-output name)))
(cond ((not maybe) #f)
((eq? 'import (sassy-symbol-scope maybe)) #t)
((sassy-symbol-offset maybe) #t)
(else #f))))
(define (sassy-symbol-def-error sassy-output name)
(or (not (sassy-symbol-defined? sassy-output name))
(error "re-definition of a previously defined/imported symbol" name)))
(define new-block
(let ((c 0))
(lambda () ; should use native gensym
(let ((n (string->symbol (string-append "%!%!%!block"
(number->string c)))))
(set! c (+ c 1))
n))))
; extra-proc is a proc of one argument that does something with each
; new sassy-symbol record, or #f
(define (setup-locals locals outp extra-proc)
(let* ((newb (new-block))
(old-env (sassy-symbol-table outp))
(restore! (lambda ()
(sassy-symbol-table-set! outp old-env))))
(sassy-symbol-table-set!
outp
(let iter ((rest locals))
(if (null? rest)
old-env
(let ((new-sym (make-sassy-symbol
(valid-label (car rest)) newb 'text #f #f '() #f)))
(if extra-proc
(extra-proc new-sym))
(cons new-sym (iter (cdr rest)))))))
restore!))
(define valid-label
(let ((keywords '(seq begin inv if iter while with-win
with-lose with-win-lose esc
mark leap label)))
(lambda (x) (or (and (symbol? x)
(not (member x keywords))
x)
(error "sassy: invalid label" x)))))
(define (get-reloc-target target outp)
(if (symbol? target)
(let ((s (sassy-symbol-exists-env? outp target)))
(if s
(case (sassy-symbol-scope s)
((local import export) target)
(else #f))
target))
#f))
(define (check-label-size size cur-byte-size key label)
(if (not (= size cur-byte-size))
(error
"wrong data size for label or custom reloc under "
`(bits ,(* 8 cur-byte-size)) (list key label))))

136
module/language/sassy/macros.scm Normal file
View file

@ -0,0 +1,136 @@
; macros.scm - Sassy's macro system
; Copyright (C) 2005 Jonathan Kraut
; This library is free software; you can redistribute it and/or
; modify it under the terms of the GNU Lesser General Public
; License as published by the Free Software Foundation; either
; version 2.1 of the License, or (at your option) any later version.
; This library is distributed in the hope that it will be useful,
; but WITHOUT ANY WARRANTY; without even the implied warranty of
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
; Lesser General Public License for more details.
; You should have received a copy of the GNU Lesser General Public
; License along with this library; if not, write to the Free Software
; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
; Contact:
; Jonathan Kraut
; 4130 43 ST #C2
; Sunnyside, NY 11104
; jak76@columbia.edu
; see file COPYING in the top of Sassy's distribution directory
; module macros
; import srfi-69 intern
; import-syntax meta-lambda
; export sassy-expand
(define sassy-expand
(let
((sassy-internal-macros ; permanent macros
(alist->hash-table
`((< . ,(lambda (a b) `(seq (cmp ,a ,b) l!)))
(<= . ,(lambda (a b) `(seq (cmp ,a ,b) le!)))
(> . ,(lambda (a b) `(seq (cmp ,a ,b) g!)))
(>= . ,(lambda (a b) `(seq (cmp ,a ,b) ge!)))
(= . ,(lambda (a b) `(seq (cmp ,a ,b) e!)))
(!= . ,(lambda (a b) `(seq (cmp ,a ,b) ne!)))
(zero? . ,(lambda (x) `(seq (test ,x ,x) z!)))
(asciiz . ,(lambda (x) `(bytes ,x 0)))
(alt . ,(lambda x `(inv (seq ,@(map (lambda (y)
`(inv ,y))
x)))))
(times . ,(lambda (num e)
(cons 'begin (make-list num e))))
(until . ,(lambda (test body) `(while (inv ,test) ,body)))
(cs: . ,(lambda rst `(cs (& ,@rst))))
(ds: . ,(lambda rst `(ds (& ,@rst))))
(ss: . ,(lambda rst `(ss (& ,@rst))))
(es: . ,(lambda rst `(es (& ,@rst))))
(fs: . ,(lambda rst `(fs (& ,@rst))))
(gs: . ,(lambda rst `(gs (& ,@rst))))
(_global_offset_table_ . ,(string->symbol "_GLOBAL_OFFSET_TABLE_"))
(get-got . (seq (call $eip)
(pop ebx)
(add ebx (reloc gotpc _global_offset_table_ 3))))
(got-offset . ,(lambda (sym . vals)
`(reloc gotoff ,sym ,(if (null? vals)
0
(apply + vals)))))
(got . ,(lambda (symbol) `(reloc got32 ,symbol)))
(plt . ,(lambda (symbol) `(reloc plt32 ,symbol)))
(sym . ,(lambda (symbol) `(reloc sym32 ,symbol)))))))
(letrec
;sassy-user-macros is updated with a new hash-table every time
;sassy is called, but since it keeps the last table around,
;you can call sassy-expand yourself to see how something got
;expanded
((sassy-user-macros (make-hash-table))
(make-sassy-macro
(meta-lambda
(or (and 'lambda __ (lambda x
(eval `(lambda ,@x)
(interaction-environment))))
,@?)))
(macro? (lambda (x)
(and (symbol? x)
(or (hash-table-ref
sassy-user-macros x (lambda () #f))
(hash-table-ref
sassy-internal-macros x (lambda () #f))))))
(call-macro (lambda (macro-call args)
(expand (if (procedure? macro-call)
(apply macro-call args)
(cons macro-call args)))))
(do-scheme-call (lambda (scheme-call)
(expand
(eval scheme-call
(interaction-environment)))))
(symbol-or-expand (lambda (x) (if (pair? x) (expand x) x)))
(atom? (lambda (x) (not (pair? x))))
(expand
(meta-lambda
(or (and ,@macro? (lambda (constant) (expand constant)))
,@atom?
(and 'label symbol-or-expand (* expand)
(lambda (label rest)
`(label ,label ,@rest)))
(and 'locals ((* symbol-or-expand)) (* expand)
(lambda (decs rest)
`(locals ,decs ,@rest)))
(and '! ? (lambda (scheme-call) (do-scheme-call scheme-call)))
(and 'macro symbol? ?
(lambda (macro-name macro-body)
(hash-table-set! sassy-user-macros macro-name
(make-sassy-macro macro-body))
'void))
(and macro? (* expand) (lambda (macro-call args)
(call-macro macro-call args)))
(and ((and '! ?)) (* expand)
(lambda (scheme-call tail)
(let ((new-head (do-scheme-call scheme-call)))
(cond ((macro? new-head) =>
(lambda (mac)
(call-macro mac tail)))
((procedure? new-head)
(call-macro new-head tail))
(else (cons new-head tail))))))
(and ? (* expand) (lambda (head tail) (cons head tail)))
))))
(lambda (list-or-hashtable)
(if (hash-table? list-or-hashtable)
(set! sassy-user-macros list-or-hashtable)
(expand list-or-hashtable))))))

58
module/language/sassy/main.scm Normal file
View file

@ -0,0 +1,58 @@
; main.scm - Sassy's main
; Copyright (C) 2005 Jonathan Kraut
; This library is free software; you can redistribute it and/or
; modify it under the terms of the GNU Lesser General Public
; License as published by the Free Software Foundation; either
; version 2.1 of the License, or (at your option) any later version.
; This library is distributed in the hope that it will be useful,
; but WITHOUT ANY WARRANTY; without even the implied warranty of
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
; Lesser General Public License for more details.
; You should have received a copy of the GNU Lesser General Public
; License along with this library; if not, write to the Free Software
; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
; Contact:
; Jonathan Kraut
; 4130 43 ST #C2
; Sunnyside, NY 11104
; jak76@columbia.edu
; see file COPYING in the top of Sassy's distribution directory
; module parse
; import macros api parse
; export sassy
;=======================;
; ;
; Sassy Main ;
; ;
;=======================;
(define (sassy input)
(let ((output (make-sassy-output
(list (make-hash-table)) ; empty symbol table
'() ; empty reloc list
#f ; no entry point
(make-pushdown-stack) ; empty data stack
(make-pushdown-stack) ; empty text stack
4 ; default heap align
4 ; default data align
16 ; default text align
0 ; initial heap size
0 ; default text org
32))) ; default bits size
(sassy-expand (make-hash-table)) ; install fresh macro table
(cond ((string? input) (parse-directives (read-file input) output))
((pair? input) (parse-directives input output))
(else (error "sassy: bad input" input)))
(sassy-symbol-table-set! output (car (sassy-symbol-table output)))
output))

491
module/language/sassy/meta-lambda.scm Normal file
View file

@ -0,0 +1,491 @@
; meta-lambda.scm - A simple parser generator
; Copyright (C) 2005 Jonathan Kraut
; This library is free software; you can redistribute it and/or
; modify it under the terms of the GNU Lesser General Public
; License as published by the Free Software Foundation; either
; version 2.1 of the License, or (at your option) any later version.
; This library is distributed in the hope that it will be useful,
; but WITHOUT ANY WARRANTY; without even the implied warranty of
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
; Lesser General Public License for more details.
; You should have received a copy of the GNU Lesser General Public
; License along with this library; if not, write to the Free Software
; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
; Contact:
; Jonathan Kraut
; 4130 43 ST #C2
; Sunnyside, NY 11104
; jak76@columbia.edu
; see file COPYING in the top of Sassy's distribution directory
; module meta-lambda
; export-syntax meta-lambda case-meta-lambda memoize
; Meta-lambda
; Another Henry Baker-inspired hack. see:
; http://home.pipeline.com/~hbaker1/Prag-Parse.html
; See after the code for documentation
(define-syntax meta-expand
(syntax-rules (or and lambda begin quote unquote
unquote-splicing __ ? + * ?* else)
((_ p i r (quote a)) (and (not (null? i))
(pair? i)
(equal? 'a (car i))
(begin (set! i (cdr i)) #t)))
((_ p i r (unquote a)) (and (not (null? i))
(pair? i)
(equal? a (car i))
(begin (set! i (cdr i)) #t)))
((_ p i r (unquote-splicing a)) (begin (set! i (list i))
(meta-expand p i r a)))
((_ p i r (or a ...)) (let ((ti i) (tp p))
(or (or (meta-expand p i r a)
(begin (set! i ti)
(set-cdr! tp '())
(set! p tp)
#f))
...)))
((_ p i r (and a ...)) (and (meta-expand p i r a) ...))
((_ p i r (lambda a b ...)) (and (null? i)
(apply (lambda a b ...) (cdr r))))
((_ p i r (begin a b ...)) (and (null? i) (begin a b ...)))
((_ p i r (else a)) (let ((tmp (a i)))
(set! i '())
tmp))
((_ p i r (+ a)) (let* ((nr (list #t))
(np nr))
(and (meta-expand np i nr a)
(do () ((not (meta-expand np i nr a))
(set! nr (list (cdr nr)))
(set-cdr! p nr)
(set! p nr)
#t)))))
((_ p i r (* a)) (let* ((nr (list #t))
(np nr))
(do () ((not (meta-expand np i nr a))
(set! nr (list (cdr nr)))
(set-cdr! p nr)
(set! p nr)
#t))))
((_ p i r (?* a)) (or (meta-expand p i r a)
#t))
((_ p i r ()) (null? i))
((_ p i r (a)) (and (not (null? i))
(pair? i)
(cond (((meta-lambda a) (car i)) =>
(lambda (res)
(if (not (eq? #t res))
(begin (set! res (list res))
(set-cdr! p res)
(set! p res)))
(set! i (cdr i))
#t))
(else #f))))
((_ p i r __) (if (or (pair? i) (null? i))
(begin (set-cdr! p i) (set! p i) (set! i '()) '__tail)
#f))
((_ p i r ?) (and (not (null? i))
(pair? i)
(let ((t (list (car i))))
(set-cdr! p t)
(set! p t)
(set! i (cdr i))
#t)))
((_ p i r x) (let-syntax ((test (syntax-rules ()
((test x w l) w)
((test y w l) l))))
(test __fubar__
(and (not (null? i))
(pair? i)
(cond ((x (car i)) =>
(lambda (res)
(let ((tmp (if (eq? res #t)
(list (car i))
(list res))))
(set-cdr! p tmp)
(set! p tmp)
(set! i (cdr i)) #t)))
(else #f)))
(and (not (null? i))
(pair? i)
(equal? x (car i))
(begin (set! i (cdr i)) #t)))))))
(define-syntax meta-lambda
(syntax-rules ()
((meta-lambda grammar)
(lambda (i)
(let* ((r (list #t))
(p r))
(cond ((meta-expand p i r grammar)
=> (lambda (res)
(if (null? i)
(if (eq? res #t)
(cond ((null? (cdr r)) #t)
((null? (cddr r)) (cadr r))
(else (cdr r)))
(if (eq? res '__tail) (cdr r) res))
#f)))
(else #f)))))))
; var-arity meta-lambda
(define-syntax meta-lambda-dot
(syntax-rules ()
((_ x y ...) (lambda args
(let ((tmp (meta-lambda x y ...)))
(tmp args))))))
; Something useful to wrap meta-lambda in to hurry things along.
; Of course only use this when not using side-effects.
(define-syntax memoize
(syntax-rules ()
((_ proc)
(let ((the-proc proc))
(let ((last-in '%#$%#%#$%)
(last-out #f))
(lambda (arg2)
(if (eq? arg2 last-in)
last-out
(begin (set! last-in arg2)
(set! last-out (the-proc arg2))
last-out))))))))
; |===========|
; |Meta-lambda|
; |===========|
; Meta-lambda is a macro for building parsers and pattern matchers
; over lists or single items. You can also specify "actions" to be
; performed when a list has been successfully parsed, so it can also
; function as a very rudimentary compiler-generator or
; attribute-grammar-generator (using synthesized attributes).
; It's really for constructing simple embedded langauges, and it has its
; limitations if your're not willing to factor out tougher grammars by
; hand. But I've found it useful.
; Here's a simple example so you can see where this is going:
; |=====|
; |Usage|
; |=====|
; meta-lambda grammer -> procedure
; Grammars are described below. The procedure generated is a procedure
; of one argument. When applied to an item (usually a list), it attempts
; to match the grammar with the list and perform any actions specified
; if it was able to completely match all the items in the list (to the
; end of the list). If the list or item can not be matched completely,
; the procedure returns #f.
; |==============|
; |The Basic Idea|
; |==============|
; Meta-lambda distinguishes between literals, and identifiers it expects
; to be bound to "predicate-like" procedures. These are procedures of one
; argument that return either #t or #f (like the usual scheme
; predicates like symbol? or number?), or another value.
; As it processes each input-item and the accompanying grammar-item, if
; the grammar-item is a literal that is equal? to the input-item, then
; meta-lambda accepts the match but discards the input item.
; If the grammar-item is a predicate-procedure, then meta-lambda applies
; that procedure to the input-item. If the result is #f, the match
; fails. If the result is #t, meta-lambda saves the input item in an
; internal accumulator-stack. If the result is any other value,
; meta-lambda saves that value in the stack, instead of the input item.
; Then, when and if the list is empty and meta-lambda encounters an
; action (expressed as a lambda expression in the grammar), meta-lambda
; applies that lambda expression to the items in the stack, and returns
; the result. (The "stack" is a list). Thus if a lambda-expression is
; supplied as an action it must contain as many arguments as there were
; predicate-procedures preceeding it.
; Since lambda-expression's denote actions to be taken at the end of a
; match (when the input-list is null), predicate procedures must be
; expressed by writing the identifier they are bound to. (No anonymous
; predicates!)
; You don't have to supply an action. In that case, if the stack is
; empty, meta-lambda returns true. If there is one item on the stack,
; meta-lambda returns that item. Otherwise, it returns the whole stack
; (as a list).
; There are other options, but that's the gist of it.
; (define match-foo-bar
; (meta-lambda
; (and 'foo 'bar (lambda () 'tada))))
; (match-foo-bar '(foo bar)) => 'tada
; (match-foo-bar '(3 cat dog)) => #f
; (define match-symbol-number-foo
; (meta-lambda
; (and symbol? number? 'foo (lambda (sym num)
; (string-append (symbol->string sym)
; (number->string num))))))
; (match-symbol-number-foo '(cat 3 foo)) => "cat3"
; (match-symbol-number-foo '(cat foo foo)) => #f
; (define both-of-em
; (meta-lambda
; (and match-foo-bar match-symbol-number-foo)))
; (both-of-em '((foo bar) (cat 3 foo))) => '(tada "cat3")
; |========|
; |Grammars|
; |========|
; grammar = (or <grammar> ...) ;choice
; | (and <grammer> ...) ;sequence
; | (+ <grammar>) ;kleene+
; | (* <grammar>) ;kleene*
; | (?* <grammar>) ;kleene?
; | <literal> ;literals
; | <identifier> ;predicate-binding
; | () ;end-of-list
; | ? ;anything
; | __ ;rest-of-list
; | (<grammar>) ;sublist
; | (unquote <identifier>) ;location
; | (unquote-splicing <grammer>) ;not-a-list
; | <action> ;result action
; | (else <procedure>) ;else-clause
; action = (lambda <formals> <body>)
; | (begin <sequence>)
; literal = (quote <scheme datum>)
; | <char>
; | <number>
; | <string>
; |==================|
; |The usual suspects|
; |==================|
; choice
; ======
; (or <grammar> ...)
; Try to match each grammar against the input in order. If a match
; fails, backtrack on the input and revert the stack.
; sequence
; ========
; (and <grammer> ...)
; Match each grammar against an item in the input, failing as soon as a
; match fails
; literals
; ========
; 'cat 'dog "three" 34 #\a '(a b c) etc.
; Compare the input item with the literal using equal?, and discard the
; input and proceed if the result is #t, otherwise fail
; identifier
; ==========
; symbol? number? boolean? match-and-do-something
; The identifier should be bound to a procedure of one argument that
; returns one value. If the result of applying the procedure to the next
; input item is #f, then fail. If the result is #t, then save the
; input-item on the stack and proceed. If the result is any other value,
; save that value on the stack in place of the input item, and proceed.
; action
; ======
; (lambda (x y) <stuff>)
; (begin (display "foo") (narfle! garthaks))
; If there is any input remaining, these immediately fail. Otherwise, if
; a "lambda", apply the lambda to the accumulated stack of
; predicate-matched items and return the result. If a "begin", ignore
; the stack and perform the sequence, returning the result.
; |================|
; |Useful additions|
; |================|
; kleene-star
; ===========
; (* <grammar>)
; Match zero or more occurrences of the grammar, and place the list of
; the results on the stack.
; kleene-plus
; ===========
; (* <grammar>)
; Match one or more occurrences of the grammar, and place the list of
; the results on the stack. (If no results than '() is placed on the
; stack).
; kleene?
; ===========
; (?* <grammar>)
; Match zero or one occurrences of the grammar, and place the list of
; the results on the stack, or do nothing.
; anything
; ========
; ?
; Automatically match anything and put it on the input stack.
; rest-of-list
; ============
; __
; Automatically match the rest of a list and place it on the input stack.
; If followed by a lambda-action, it should be a variable arity lambda in order to bind the result of the match of __.
; (define number-and-rest
; (meta-lambda
; (and number? __ (lambda (num . rest)
; (cons num (cadr rest))))))
; (number-and-rest '(3 cat dog foo)) => '(3 . dog)
; |=============|
; |Weirder stuff|
; |=============|
; end-of-list
; ===========
; ()
; Explicitly match the end of list and proceed.
; sub-lists
; =========
; (<grammar>)
; Ah, trees. Wrapping a parens around a grammar causes meta-lambda to
; expect a sublist. It itself can contain actions that return
; values. The sublist is matched and returns results as if you had
; written a separte meta-lambda for the sublist, and whatever it returns
; is placed on the stack as a single item.
; (define match-lambda-one
; (meta-lambda
; (and 'lambda (symbol?) ? (lambda (formals body)
; `(forms ,@formals)))))
; (match-lambda-one '(lambda (a) (foo a (bar b c)))) => '(forms . a)
; (define match-lambda
; (meta-lambda
; (and 'lambda ((* symbol?)) ? (lambda (formals body)
; `(forms ,@formals)))))
; (match-lambda '(lambda (a b c) (foo a (bar b c)))) => '(forms a b c)
; location
; ========
; (unquote <identifier>)
; This means match the literal that is bound to the identifier against
; the next input. Useful for parameterizing.
; (define (make-foo-matcher x)
; (meta-lambda
; (and 'foo ,x)))
; (define foo-3 (make-foo-matcher 3))
; (define foo-cat (make-foo-matcher 'cat))
; (foo-3 '(foo 3)) => #t
; (foo-3 '(foo 4)) => #f
; (foo-cat '(foo cat)) => #t
; (foo-cat '(foo 3)) => #f
; not-a-list
; ==========
; (unquote-splicing <grammar>)
; Wrap the input (or the next item in the input) in a list, and then
; match. This way meta-lambda can match lists or single items.
; (define infix
; (let ((op? (meta-lambda ;doing this for demo purposes. (case ...)
; ;is better here
; (or (and ,@'+ (begin +))
; (and ,@'- (begin -))
; (and ,@'* (begin *))))))
; (meta-lambda
; (or ,@integer?
; (and infix op? infix (lambda (a op b) (op a b)))))))
; (infix '((3 + 4) * ((6 - 3) + 4))) => 49
; else
; ====
; (else <procedure>)
; If an else-clause is encountered, the rest of the input is immediately
; accepted, but instead of being accepted on the stack, it is
; immediately passed to <procedure>, which should be variable arity. The
; proedure's result, if it returns at all, becomes the result of the
; whole meta-lambda.
; (define infix2
; (let ((op? (lambda (y)
; (case y
; ((+) +)
; ((-) -)
; ((*) *)))))
; (meta-lambda
; (or ,@integer?
; (and infix op? infix (lambda (a op b) (op a b)))
; (else (lambda x (error "bad input" x)))))))
; (infix2 '((3 + 4) * ((foo - 3) + 4))) => &error bad input (foo)
; |======|
; |Extras|
; |======|
; meta-lambda-dot grammer -> procedure
; Like meta-lambda, but the procedure returned is variable arity as in:
; (lambda x ...)
; The match procedure is applied to the list "x"

108
module/language/sassy/numbers.scm Normal file
View file

@ -0,0 +1,108 @@
; numbers.scm - Sassy's number predicates
; Copyright (C) 2005 Jonathan Kraut
; This library is free software; you can redistribute it and/or
; modify it under the terms of the GNU Lesser General Public
; License as published by the Free Software Foundation; either
; version 2.1 of the License, or (at your option) any later version.
; This library is distributed in the hope that it will be useful,
; but WITHOUT ANY WARRANTY; without even the implied warranty of
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
; Lesser General Public License for more details.
; You should have received a copy of the GNU Lesser General Public
; License along with this library; if not, write to the Free Software
; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
; Contact:
; Jonathan Kraut
; 4130 43 ST #C2
; Sunnyside, NY 11104
; jak76@columbia.edu
; see file COPYING in the top of Sassy's distribution directory
; module numbers
; import srfi-60
; import-syntax meta-lambda
; export all
; also loads "other/srfi-56-pieces.scm"
(define s-byte #f)
(define s-word #f)
(define s-dword #f)
(define s-qword #f)
(define u-byte #f)
(define u-word #f)
(define u-dword #f)
(define u-qword #f)
(let ((signed-x (lambda (bitfield)
(lambda (number)
(and (integer? number)
(let ((tester (logand number bitfield)))
(or (zero? tester) (= tester bitfield)))))))
(unsigned-x (lambda (bitfield)
(lambda (number)
(and (integer? number)
(= bitfield (logior number bitfield)))))))
(define s-byte-x (signed-x (- (expt 2 7))))
(define s-word-x (signed-x (- (expt 2 15))))
(define s-dword-x (signed-x (- (expt 2 31))))
(define s-qword-x (signed-x (- (expt 2 63))))
(define u-byte-x (unsigned-x (- (expt 2 8) 1)))
(define u-word-x (unsigned-x (- (expt 2 16) 1)))
(define u-dword-x (unsigned-x (- (expt 2 32) 1)))
(define u-qword-x (unsigned-x (- (expt 2 64) 1)))
(let ((num-x (lambda (pred key)
(meta-lambda
(or ,@pred
(and ,key pred))))))
(set! s-byte (memoize (num-x s-byte-x 'byte)))
(set! s-word (memoize (num-x s-word-x 'word)))
(set! s-dword (memoize (num-x s-dword-x 'dword)))
(set! s-qword (memoize (num-x s-qword-x 'qword)))
(set! u-byte (memoize (num-x u-byte-x 'byte)))
(set! u-word (memoize (num-x u-word-x 'word)))
(set! u-dword (memoize (num-x u-dword-x 'dword)))
(set! u-qword (memoize (num-x u-qword-x 'qword)))))
(define (u/s-byte x) (or (s-byte x) (u-byte x)))
(define (u/s-word x) (or (s-word x) (u-word x)))
(define (u/s-dword x) (or (s-dword x) (u-dword x) (real? x)))
(define (u/s-qword x) (or (s-qword x) (u-qword x) (real? x)))
; The byte-list returned is little-endian
(define (number->byte-list number size)
(cond ((integer? number) (integer->byte-list number size))
((real? number)
(cond ((= 4 size) (float32->byte-list number))
((= 8 size) (float64->byte-list number))
(else (error "bad size for float" number size))))
(else (error "not a number sassy can assemble" number))))
; The following all return little-endian byte-lists
; Very few scheme implementations provide something like
; integer->bytes or float->bytes. Those that do (including slib)
; return a string, so I would have write:
; (map char->integer (string->list (integer/float->bytes ...)))
; which is less efficient for sassy. So I'm using these instead...
(define (integer->byte-list orig-int orig-size)
(let iter ((int orig-int) (size orig-size))
(if (zero? size)
(if (or (zero? orig-int)
(and (positive? orig-int) (zero? int))
(and (negative? orig-int) (= -1 int)))
'()
(error "integer too big for field width" orig-int orig-size))
(cons (logand int 255) (iter (ash int -8) (- size 1))))))
; (load "other/srfi-56-pieces.scm")

1732
module/language/sassy/opcodes.scm Normal file
View file

File diff suppressed because it is too large Load diff

244
module/language/sassy/operands.scm Normal file
View file

@ -0,0 +1,244 @@
; operands.scm - Sassy's operand predicates
; Copyright (C) 2005 Jonathan Kraut
; This library is free software; you can redistribute it and/or
; modify it under the terms of the GNU Lesser General Public
; License as published by the Free Software Foundation; either
; version 2.1 of the License, or (at your option) any later version.
; This library is distributed in the hope that it will be useful,
; but WITHOUT ANY WARRANTY; without even the implied warranty of
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
; Lesser General Public License for more details.
; You should have received a copy of the GNU Lesser General Public
; License along with this library; if not, write to the Free Software
; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
; Contact:
; Jonathan Kraut
; 4130 43 ST #C2
; Sunnyside, NY 11104
; jak76@columbia.edu
; see file COPYING in the top of Sassy's distribution directory
; module operands
; import numbers srfi-69
; import-syntax meta-lambda
; export all
; register type operands
(define r8 #f)
(define r16 #f)
(define r32 #f)
(define mm #f)
(define st #f)
(define xmm #f)
(define creg #f)
(define dreg #f)
(define sreg #f)
(define (r32-not-esp x) (and (not (eq? x 'esp)) (r32 x)))
(define (sreg-not-cs x) (and (not (eq? x 'cs)) (sreg x)))
(define symbol #f)
(let
((the-registers
(alist->hash-table
'((eax . (32 . 0)) (ecx . (32 . 1)) (edx . (32 . 2)) (ebx . (32 . 3))
(esp . (32 . 4)) (ebp . (32 . 5)) (esi . (32 . 6)) (edi . (32 . 7))
(ax . (16 . 0)) (cx . (16 . 1)) (dx . (16 . 2)) (bx . (16 . 3))
(sp . (16 . 4)) (bp . (16 . 5)) (si . (16 . 6)) (di . (16 . 7))
(al . (8 . 0)) (cl . (8 . 1)) (dl . (8 . 2)) (bl . (8 . 3))
(ah . (8 . 4)) (ch . (8 . 5)) (dh . (8 . 6)) (bh . (8 . 7))
(st0 . (80 . 0)) (st1 . (80 . 1)) (st2 . (80 . 2)) (st3 . (80 . 3))
(st4 . (80 . 4)) (st5 . (80 . 5)) (st6 . (80 . 6)) (st7 . (80 . 7))
(mm0 . (64 . 0)) (mm1 . (64 . 1)) (mm2 . (64 . 2)) (mm3 . (64 . 3))
(mm4 . (64 . 4)) (mm5 . (64 . 5)) (mm6 . (64 . 6)) (mm7 . (64 . 7))
(xmm0 . (128 . 0)) (xmm1 . (128 . 1)) (xmm2 . (128 . 2))
(xmm3 . (128 . 3)) (xmm4 . (128 . 4)) (xmm5 . (128 . 5))
(xmm6 . (128 . 6)) (xmm7 . (128 . 7))
(es . (1 . 0)) (cs . (1 . 1)) (ss . (1 . 2))
(ds . (1 . 3)) (fs . (1 . 4)) (gs . (1 . 5))
(cr0 . (2 . 0)) (cr2 . (2 . 2)) (cr3 . (2 . 3)) (cr4 . (2 . 4))
(dr0 . (3 . 0)) (dr1 . (3 . 1)) (dr2 . (3 . 2))
(dr3 . (3 . 3)) (dr6 . (3 . 6)) (dr7 . (3 . 7))
)))) ;sreg type-code = 1 creg type-code = 2 dreg type-code = 3
(let ((reg-x (lambda (reg-type-code)
(memoize
(lambda (x)
(cond ((hash-table-ref the-registers x (lambda () #f)) =>
(lambda (found)
(and (= reg-type-code (car found)) (cdr found))))
(else #f)))))))
(set! r8 (reg-x 8))
(set! r16 (reg-x 16))
(set! r32 (reg-x 32))
(set! mm (reg-x 64))
(set! st (reg-x 80))
(set! xmm (reg-x 128))
(set! creg (reg-x 2))
(set! dreg (reg-x 3))
(set! sreg (reg-x 1))
(set! symbol (memoize
(lambda (x)
(or (and (symbol? x)
(not (hash-table-ref the-registers
x (lambda () #f)))
x)
(custom-reloc x)))))))
; For the remainder of the following, every operand is either an e_ u_
; or general. The u-types are for unexplicit operand sizes. The
; e-types are for the cases where the operand size if explicit, and
; the general is either of those.
; mem type operands - the actual parsing happens in proc-mem in operands
(define um8
(memoize
(let ((segger (lambda (x) (and (memq x '(cs ss ds es fs gs)) x)))
(mem (meta-lambda (and '& __))))
(meta-lambda
(or ,@mem
(and segger mem))))))
(define um16 um8)
(define um32 um8)
(define um64 um8)
(define um80 um8)
(define um128 um8)
(define em8 (memoize (meta-lambda (and 'byte um8))))
(define em16 (memoize (meta-lambda (and 'word um16))))
(define em32 (memoize (meta-lambda (and 'dword um32))))
(define em64 (memoize (meta-lambda (and 'qword um64))))
(define em80 (memoize (meta-lambda (and 'tword um80))))
(define em128 (memoize (meta-lambda (and 'dqword um128))))
(define (m8 x) (or (um8 x) (em8 x)))
(define (m16 x) (or (um16 x) (em16 x)))
(define (m32 x) (or (um32 x) (em32 x)))
(define (m64 x) (or (um64 x) (em64 x)))
(define (m80 x) (or (um80 x) (em80 x)))
(define (m128 x) (or (um128 x) (em128 x)))
(define (mem-any x)
(or (m32 x) (m16 x) (m8 x) (m64 x) (m80 x) (m128 x)))
; NOTE: This needs fixing. The current bit-size should be checked to
; make sure that "target" and "value", if specified, fit within the
; current bit size.
(define custom-reloc
(meta-lambda
(and 'reloc
(or (and 'rel
(or symbol? u-dword)
(or (lambda (target) (list 'reloc 'rel target 0))
(else (lambda x (error "sassy: bad rel reloc" x)))))
(and symbol?
(or (lambda (type) (list 'reloc type #f 0))
(and (or symbol? u-dword)
(or (lambda (type target) (list 'reloc type target 0))
(and s-dword
(lambda (type target value)
(list 'reloc type target value)))))))))))
; rel type operands are used by branches
(define urel8 (memoize (meta-lambda (or ,@u-byte ,@symbol))))
(define urel16 (memoize (meta-lambda (or ,@u-word ,@symbol))))
(define urel32 (memoize (meta-lambda (or ,@u-dword ,@symbol))))
(define erel8 (memoize (meta-lambda (and 'byte urel8))))
(define erel16 (memoize (meta-lambda (and 'word urel16))))
(define erel32 (memoize (meta-lambda (and 'dword urel32))))
(define (rel8 x) (or (urel8 x) (erel8 x)))
(define (rel16 x) (or (urel16 x) (erel16 x)))
(define (rel32 x) (or (urel32 x) (erel32 x)))
; mi type operand is used by mov instruction only with eax
(define umi8 #f)
(define umi16 #f)
(define umi32 #f)
(define emi8 (memoize (meta-lambda (and 'byte umi8))))
(define emi16 (memoize (meta-lambda (and 'word umi16))))
(define emi32 (memoize (meta-lambda (and 'dword umi32))))
(define (mi8 x) (or (umi8 x) (emi8 x)))
(define (mi16 x) (or (umi16 x) (emi16 x)))
(define (mi32 x) (or (umi32 x) (emi32 x)))
(let ((mi (lambda (x)
(let ((asym #f)
(acc 0))
(let ((a-rest
(meta-lambda
(or (and ,@symbol
(lambda (x) (and (not asym) (set! asym x))))
(and ,@integer?
(lambda (x) (set! acc (+ x acc))))))))
(let ((go (meta-lambda
(and '& (+ a-rest)
(begin
(cond ((pair? asym)
(list 'reloc (car asym) (cadr asym)
(+ acc (caddr asym))))
((symbol? asym)
(list 'reloc 'abs asym acc))
((not asym) acc)))))))
; (list 'reloc 'abs acc 0))))))))
(go x)))))))
(set! umi8 mi)
(set! umi16 mi)
(set! umi32 mi))
; immediate type operands
; unexplicit
(define ui8 #f)
(define ui16 #f)
(define ui32 #f)
; explicit eg (dword N)
(define ei8 (memoize (meta-lambda (and 'byte ui8))))
(define ei16 (memoize (meta-lambda (and 'word ui16))))
(define ei32 (memoize (meta-lambda (and 'dword ui32))))
; any
(define (i8 x) (or (ui8 x) (ei8 x)))
(define (i16 x) (or (ui16 x) (ei16 x)))
(define (i32 x) (or (ui32 x) (ei32 x)))
(let ((string-able
(lambda (z)
(lambda (x)
(and (string? x)
(<= (string-length x) z)
(let ((tmp (string-append x (make-string (- z (string-length x))
(integer->char 0)))))
(do ((i (- z 1) (- i 1))
(r 0 (+ (ash r 8) (char->integer (string-ref tmp i)))))
((< i 0) r))))))))
(let ((str1 (string-able 1))
(str2 (string-able 2))
(str4 (string-able 4))
(u/s-byte u/s-byte)
(u/s-word u/s-word)
(u/s-dword u/s-dword))
(let ((imm16/32
(lambda (num-pred str-pred)
(meta-lambda
(or ,@num-pred
,@symbol
,@str-pred
(and ,@char? (lambda (x) (char->integer x))))))))
(set! ui8 (memoize
(meta-lambda
(or ,@u/s-byte
,@str1
(and ,@char? (lambda (x) (char->integer x)))))))
(set! ui16 (memoize (imm16/32 u/s-word str2)))
(set! ui32 (memoize (imm16/32 u/s-dword str4))))))

282
module/language/sassy/parse.scm Normal file
View file

@ -0,0 +1,282 @@
; parse.scm - Sassy's top level parser
; Copyright (C) 2005 Jonathan Kraut
; This library is free software; you can redistribute it and/or
; modify it under the terms of the GNU Lesser General Public
; License as published by the Free Software Foundation; either
; version 2.1 of the License, or (at your option) any later version.
; This library is distributed in the hope that it will be useful,
; but WITHOUT ANY WARRANTY; without even the implied warranty of
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
; Lesser General Public License for more details.
; You should have received a copy of the GNU Lesser General Public
; License along with this library; if not, write to the Free Software
; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
; Contact:
; Jonathan Kraut
; 4130 43 ST #C2
; Sunnyside, NY 11104
; jak76@columbia.edu
; see file COPYING in the top of Sassy's distribution directory
; module parse
; import macros api text numbers opcodes push-stacks operands intern
; import-syntax meta-lambda
; export all
(define parse-directives
(let ()
(define (process-bits int output)
(if (or (= 16 int) (= 32 int))
(sassy-bits-set! output int)
(error "sassy: bad bits" int)))
(define (process-org text-base output)
(if (and (integer? text-base)
(zero? (sassy-text-size output))
(positive? text-base))
(sassy-text-org-set! output text-base)
(error "sassy: bad org" text-base)))
(define (process-entry entry-label output)
(if (symbol? entry-label)
(begin (sassy-symbol-set! output entry-label '(scope export))
(sassy-entry-point-set! output entry-label))
(error "sassy: bad entry" entry-label)))
(define (process-include include-list output)
(for-each
(lambda (x)
(cond ((string? x) (parse-directives (read-file x) output))
((symbol? x) (parse-directives (eval x
(interaction-environment))
output))
(else (error "sassy: bad include" x))))
include-list))
(define (process-scopes scope-list scope output)
(for-each (lambda (x)
(if (eq? 'import scope)
(sassy-symbol-def-error output x))
(if (symbol? x)
(sassy-symbol-set! output x `(scope ,scope))
(error "sassy: bad scope" scope x)))
scope-list))
(define (align-to count align)
(let ((diff (modulo count align)))
(if (zero? diff)
0
(- align diff))))
(define aligner
(let ((power-of-2 (lambda (x)
(and (integer? x) (positive? x)
(zero? (logand x (- x 1)))
x))))
(meta-lambda
(and 'align power-of-2))))
(define (process-heap heap-list output)
(letrec
((heap-sizer
(meta-lambda
(or (and 'bytes u-dword)
(and 'words u-dword (lambda (units) (* units 2)))
(and 'dwords u-dword (lambda (units) (* units 4)))
(and 'qwords u-dword (lambda (units) (* units 8))))))
(heap-item
(meta-lambda
(or
(and ,@aligner (lambda (align)
(let ((size (sassy-heap-size output)))
(sassy-heap-size-set!
output (+ size (align-to size align)))
(when (> align (sassy-heap-align output))
(sassy-heap-align-set! output align)))))
(and ,@heap-sizer (lambda (sizer)
(sassy-heap-size-set!
output (+ sizer (sassy-heap-size output)))))
(and 'label valid-label __
(lambda (label . rst)
(let ((current-size (sassy-heap-size output)))
(sassy-symbol-def-error output label)
(sassy-symbol-set! output label '(section heap)
`(offset ,current-size) '(size 0))
(for-each heap-item rst)
(sassy-symbol-set! output label
`(size ,(- (sassy-heap-size output)
current-size))))))
(and 'begin (* heap-item))
(else (lambda (h) (error "sassy: bad heap item" h)))))))
(for-each heap-item heap-list)))
(define (process-text text-list output)
(letrec ((text-item
(meta-lambda
(or
(and ,@aligner (lambda (align)
(push-stack-align (sassy-text-stack output)
align #x90
(sassy-text-org output))
(if (> align (sassy-text-align output))
(sassy-text-align-set! output align))))
(and 'label valid-label __
(lambda (label . opcodes-or-prims)
(sassy-symbol-def-error output label)
(sassy-symbol-set!
output label
'(section text)
`(offset ,(+ (sassy-text-org output)
(sassy-text-size output))))
(sassy-symbol-set!
output label
`(size ,(handle-text-block `(begin ,@opcodes-or-prims)
output (t-make))))))
(else (lambda (opcode-or-prim)
(handle-text-block opcode-or-prim output
(t-make))))))))
(for-each text-item text-list)))
(define (sassy-reloc-set! output name section offset type patcher)
(sassy-reloc-list-set!
output (cons (make-sassy-reloc name section offset type patcher)
(sassy-reloc-list output))))
(define (process-data data-list output)
(letrec
((current-byte-size (/ (sassy-bits output) 8))
(char/str/num
(lambda (item size)
(let ((data-stack (sassy-data-stack output)))
(cond ((char? item)
(push-stack-push data-stack (char->integer item))
(push-stack-align data-stack size 0))
((string? item)
(push-stack-push data-stack
(map char->integer (string->list item)))
(push-stack-align data-stack size 0))
((number? item)
(push-stack-push data-stack
(number->byte-list item size)))
(else (lambda (i) (error "sassy: bad data" i)))))))
(handle-data-symbol
(lambda (type target value)
(when (eqv? 'rel type)
(error "no rel relocations in data section right now"
(list 'reloc type target value)))
(when (eqv? '$here target)
(set! target (sassy-data-size output)))
(let* ((offset (sassy-data-size output))
(target-value (cond ((sassy-symbol-exists-env?
output target)
=>
(lambda (x) (sassy-symbol-offset x)))
(else target)))
(a-reloc (make-sassy-reloc
(get-reloc-target target output)
'data offset type #f value current-byte-size))
(patcher (let ((p (push-stack-push->patcher
(sassy-data-stack output)
(number->byte-list value
current-byte-size))))
(lambda (new)
(p (number->byte-list new current-byte-size))
(sassy-reloc-value-set! a-reloc new)))))
(sassy-reloc-patcher-set! a-reloc patcher)
(sassy-reloc-list-set! output
(cons a-reloc (sassy-reloc-list output)))
(if (number? target-value)
(patcher (+ target-value value))
(sassy-symbol-set!
output target
`(unres ,(lambda (n) (patcher (+ n value)))))))))
(data4
(meta-lambda
(or
(and ,@symbol? (lambda (label)
(check-label-size 4 current-byte-size 'dwords
label)
(handle-data-symbol 'abs label 0)))
(and ,@custom-reloc (lambda (a-reloc)
(check-label-size 4 current-byte-size
'dwords a-reloc)
(apply handle-data-symbol (cdr a-reloc))))
(else (lambda (data) (char/str/num data 4))))))
(data2
(meta-lambda
(or
(and ,@symbol? (lambda (label)
(check-label-size 2 current-byte-size 'words
label)
(handle-data-symbol 'abs label 0)))
(and ,@custom-reloc (lambda (a-reloc)
(check-label-size 2 current-byte-size
'words a-reloc)
(apply handle-data-symbol (cdr a-reloc))))
(else (lambda (data) (char/str/num data 2))))))
(data-item
(meta-lambda
(or
(and ,@aligner (lambda (align)
(push-stack-align (sassy-data-stack output)
align 0)
(if (> align (sassy-data-align output))
(sassy-data-align-set! output align))))
(and 'label valid-label __
(lambda (label . things)
(sassy-symbol-def-error output label)
(let ((offset (sassy-data-size output)))
(sassy-symbol-set! output label '(section data)
`(offset ,offset))
(for-each data-item things)
(sassy-symbol-set! output label
`(size ,(- (sassy-data-size output)
offset))))))
(and 'locals pair? __
(lambda (locals . body)
(let ((reset! (setup-locals locals output #f)))
(for-each data-item body)
(reset!))))
(and 'dwords __ (lambda datas (for-each data4 datas)))
(and 'bytes __ (lambda datas (for-each
(lambda (x) (char/str/num x 1))
datas)))
(and 'words __ (lambda datas (for-each data2 datas)))
(and 'qwords __ (lambda datas (for-each
(lambda (x) (char/str/num x 8))
datas)))
(and 'begin (* data-item))
(else (lambda (i) (error "sassy: bad data items" i)))))))
(for-each data-item data-list)))
(lambda (directives-list output)
(letrec
((parse-expand (lambda (itm) (parse (sassy-expand itm))))
(parse
(meta-lambda
(or
,@'void
(and 'text __ (lambda lst (process-text lst output)))
(and 'heap __ (lambda lst (process-heap lst output)))
(and 'data __ (lambda lst (process-data lst output)))
(and 'import __ (lambda lst (process-scopes
lst 'import output)))
(and 'export __ (lambda lst (process-scopes
lst 'export output)))
(and 'include __ (lambda lst (process-include lst output)))
; (and 'direcs __ (lambda lst (parse-directives lst output)))
(and 'entry ? (lambda (symb) (process-entry symb output)))
(and 'org ? (lambda (int ) (process-org int output)))
(and 'bits ? (lambda (int ) (process-bits int output)))
(and 'begin (* parse-expand))
(else (lambda (err) (error "sassy: bad directive" err)))))))
(for-each parse-expand directives-list)))))

187
module/language/sassy/push-stacks.scm Normal file
View file

@ -0,0 +1,187 @@
; push-stacks.scm - A stack-like data-type
; Copyright (C) 2005 Jonathan Kraut
; This library is free software; you can redistribute it and/or
; modify it under the terms of the GNU Lesser General Public
; License as published by the Free Software Foundation; either
; version 2.1 of the License, or (at your option) any later version.
; This library is distributed in the hope that it will be useful,
; but WITHOUT ANY WARRANTY; without even the implied warranty of
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
; Lesser General Public License for more details.
; You should have received a copy of the GNU Lesser General Public
; License along with this library; if not, write to the Free Software
; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
; Contact:
; Jonathan Kraut
; 4130 43 ST #C2
; Sunnyside, NY 11104
; jak76@columbia.edu
; see file COPYING in the top of Sassy's distribution directory
; module sassy-push-stacks
; import-syntax meta-lambda
; export all
(define make-pushdown-stack #f)
(define make-pushup-stack #f)
(let ((make-push-stack
(lambda (direc)
(define size 0)
(define items '())
(define pointer '())
(define down-stack-base '())
(define (cycle lst siz)
(do ((ls lst (cdr ls))
(c siz (+ c 1)))
((null? (cdr ls)) (set! size c) ls)))
(define push-gs
(if (eqv? 'up direc)
(lambda (itm-or-pr)
(and (not (pair? itm-or-pr))
(set! itm-or-pr (list itm-or-pr)))
(if (null? pointer)
(begin (set! items itm-or-pr)
(set! pointer (cycle itm-or-pr (+ size 1)))
items)
(begin (set-cdr! pointer itm-or-pr)
(let ((old (cdr pointer)))
(set! pointer (cycle pointer size))
old))))
(lambda (itm-or-pr)
(let ((push-one (lambda () ; fast path for non-pairs
(set! items (cons itm-or-pr items))
(set! pointer items)
(set! size (+ size 1)))))
(if (null? pointer)
(if (not (pair? itm-or-pr))
(begin (push-one)
(set! down-stack-base pointer)
pointer)
(begin (set! items itm-or-pr)
(set! down-stack-base
(cycle itm-or-pr (+ size 1)))
(set! pointer items)
pointer))
(if (not (pair? itm-or-pr))
(begin (push-one)
pointer)
(begin (set-cdr! (cycle itm-or-pr (+ size 1)) items)
(set! items itm-or-pr)
(set! pointer itm-or-pr)
pointer)))))))
; (and (not (pair? lst))
; (set! lst (list lst)))
; (if (null? pointer)
; (begin (set! items lst)
; (set! down-stack-base (cycle lst (+ size 1)))
; (set! pointer items)
; pointer)
; (begin (set-cdr! (cycle lst (+ size 1)) items)
; (set! items lst)
; (set! pointer lst)
; pointer)))))
(define (patch-gs pnt lst)
(do ((rst lst (cdr rst))
(loc pnt (cdr loc)))
((null? rst))
(set-car! loc (car rst))))
(define previous '())
(define append-gs
(if (eqv? 'up direc)
(lambda (stk2)
(if (memq stk2 previous)
(error "tried to append! the same stacks twice" stk2)
(begin (set! previous (cons stk2 previous))
(set! size (+ size (stk2 'size)))
(if (null? pointer)
(set! items (stk2 'items))
(set-cdr! pointer (stk2 'items)))
(let ((p (if (eqv? 'up (stk2 'direc))
(stk2 'pointer)
(stk2 'down-base))))
(if (and (not (eq? pointer p))
(not (null? p)))
(set! pointer p))))))
(lambda (stk2)
(if (memq stk2 previous)
(error "tried to append! the same stacks twice" stk2)
(begin (set! previous (cons stk2 previous))
(set! size (+ size (stk2 'size)))
(if (null? pointer)
(begin (set! items (stk2 'items))
(set! pointer items))
(set-cdr! down-stack-base (stk2 'items)))
(let ((d (if (eqv? 'up (stk2 'direc))
(stk2 'pointer)
(stk2 'down-base))))
(if (and (not (eq? down-stack-base d))
(not (null? d)))
(set! down-stack-base d))))))))
(meta-lambda-dot
(or (and 'push ? (lambda (x) (push-gs x)))
(and 'size (begin size))
(and 'patch pair? (or (and pair? (lambda (x y) (patch-gs x y)))
(and ? (lambda (x y) (set-car! x y)))))
(and 'append procedure? (lambda (x) (append-gs x)))
(and 'set-previous procedure? (lambda (x) (set! previous
(cons x previous))))
(and 'pointer (begin pointer))
(and 'down-base (begin down-stack-base))
(and 'items (begin items))
(and 'save (begin
(let ((os size) (op pointer) (oi items))
(lambda ()
(set! size os)
(set! pointer op)
(set! items oi)
(if (and (not (null? pointer)) (eqv? direc 'up))
(set-cdr! pointer '()))))))
(and 'push-proc ? (lambda (x) (let ((t (push-gs x)))
(lambda (new) (patch-gs t new)))))
(and 'direc (begin direc))
; last because it may return #f
(and 'empty (begin (null? items))))))))
(set! make-pushdown-stack (lambda () (make-push-stack 'up)))
(set! make-pushup-stack (lambda () (make-push-stack 'down))))
(define (push-stack-push stk itm) (stk 'push itm))
(define (push-stack-pointer stk) (stk 'pointer))
(define (push-stack-items stk) (stk 'items))
(define (push-stack-patch stk pnt itm) (stk 'patch pnt itm))
(define (push-stack-push->patcher stk itm) (stk 'push-proc itm))
(define (push-stack-save stk) (stk 'save))
(define (push-stack-direction stk) (stk 'direc))
(define (push-stack-size stk) (stk 'size))
(define (push-stack-append! stk1 stk2)
(stk2 'set-previous stk1)
(stk1 'append stk2))
(define (push-stack-empty? stk) (stk 'empty))
(define push-stack-align
(let ((align-to (lambda (count align)
(let ((diff (modulo count align)))
(if (zero? diff)
0
(- align diff))))))
(lambda (stk align fill . offset)
(let ((amount (align-to (+ (stk 'size)
(if (null? offset) 0 (car offset)))
align)))
(if (pair? fill)
(error "can not fill a push-stack with a pair" fill)
(when (not (zero? amount))
(stk 'push (make-list amount fill))))))))

72
module/language/sassy/text-block.scm Normal file
View file

@ -0,0 +1,72 @@
; text-block.scm - an internal data type for Sassy
; Copyright (C) 2005 Jonathan Kraut
; This library is free software; you can redistribute it and/or
; modify it under the terms of the GNU Lesser General Public
; License as published by the Free Software Foundation; either
; version 2.1 of the License, or (at your option) any later version.
; This library is distributed in the hope that it will be useful,
; but WITHOUT ANY WARRANTY; without even the implied warranty of
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
; Lesser General Public License for more details.
; You should have received a copy of the GNU Lesser General Public
; License along with this library; if not, write to the Free Software
; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
; Contact:
; Jonathan Kraut
; 4130 43 ST #C2
; Sunnyside, NY 11104
; jak76@columbia.edu
; see file COPYING in the top of Sassy's distribution directory
; module text-blocks
; import push-stacks srfi-9
; export all
(define-record-type text-block
(make-text-block a b c d e f g) text-block?
(a t-text)
(b t-reloc t-reloc-set!)
(c t-res t-res-set!)
(d t-unres t-unres-set!)
(e t-mark t-mark-set!)
(f t-label t-label-set!)
(g t-env t-env-set!))
(define (push-t-reloc! t i) (t-reloc-set! t (cons i (t-reloc t))))
(define (push-t-res! t i) (t-res-set! t (cons i (t-res t))))
(define (push-t-unres! t i) (t-unres-set! t (cons i (t-unres t))))
(define (push-t-mark! t i) (t-mark-set! t (cons i (t-mark t))))
(define (pop-t-mark! t) (let ((z (t-mark t)))
(if (not (null? z))
(begin (t-mark-set! t (cdr z))
(car z))
#f)))
(define (push-t-label! t i) (t-label-set! t (cons i (t-label t))))
(define (push-t-env! t env) (t-env-set! t (cons env (t-env t))))
(define (t-make) (make-text-block (make-pushup-stack) '() '() '() '() '() '()))
(define (t-save! t)
(let ((restore-text-block (push-stack-save (t-text t)))
(orig-reloc (t-reloc t))
(orig-res (t-res t))
(orig-unres (t-unres t))
(orig-mark (t-mark t))
(orig-label (t-label t))
(orig-env (t-env t)))
(lambda ()
(restore-text-block)
(t-reloc-set! t orig-reloc)
(t-res-set! t orig-res)
(t-unres-set! t orig-unres)
(t-mark-set! t orig-mark)
(t-label-set! t orig-label)
(t-env-set! t orig-env))))

445
module/language/sassy/text.scm Normal file
View file

@ -0,0 +1,445 @@
; text.scm - Sassy's compiler, based on COMFY-65
; (see http://home.pipeline.com/~hbaker1/sigplannotices/CFYCMP1.LSP)
; Copyright (C) 2005 Jonathan Kraut
; This library is free software; you can redistribute it and/or
; modify it under the terms of the GNU Lesser General Public
; License as published by the Free Software Foundation; either
; version 2.1 of the License, or (at your option) any later version.
; This library is distributed in the hope that it will be useful,
; but WITHOUT ANY WARRANTY; without even the implied warranty of
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
; Lesser General Public License for more details.
; You should have received a copy of the GNU Lesser General Public
; License along with this library; if not, write to the Free Software
; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
; Contact:
; Jonathan Kraut
; 4130 43 ST #C2
; Sunnyside, NY 11104
; jak76@columbia.edu
; see file COPYING in the top of Sassy's distribution directory
; module text
; import push-stacks operands opcodes numbers api text-block
; import-syntax meta-lambda
; export all
(define (handle-text-block text-item outp textb)
(define rel-adjust (if (= 16 (sassy-bits outp))
3
5))
(define current-byte-size (/ (sassy-bits outp) 8))
(define (fix-body-labels! new-text-size list-of-label-pairs)
(for-each
(lambda (label-pair)
(case (cadr label-pair)
((local import export)
(sassy-symbol-set! outp (car label-pair)
`(offset ,(- new-text-size (caddr label-pair)))))))
list-of-label-pairs))
(define (fix-block-labels! new-text-size list-of-label-pairs env)
(for-each
(lambda (exists)
(let* ((scope (sassy-symbol-scope exists))
(name (sassy-symbol-name exists))
(offs (let iter ((rst list-of-label-pairs))
(cond ((null? rst) #f)
((and (eq? scope (cadr (car rst)))
(eq? name (car (car rst))))
(caddr (car rst)))
(else (iter (cdr rst)))))))
(if offs
(let ((new-offs (- new-text-size offs)))
(sassy-symbol-offset-set! exists new-offs)
(for-each (lambda (back-patcher)
(back-patcher new-offs))
(sassy-symbol-unres exists))))))
env))
(define (fix-relocations! new-text-size list-of-new-relocs)
(for-each
(lambda (new-reloc)
(sassy-reloc-offset-set! new-reloc (- new-text-size
(sassy-reloc-offset new-reloc)))
(sassy-reloc-list-set! outp (cons new-reloc (sassy-reloc-list outp))))
list-of-new-relocs))
(define (fix-backward-refs! new-text-size list-of-patcher-pairs)
; patcher-pair: car = flipped eip, cdr = patcher-procedure
(for-each
(lambda (patcher-pair)
((cdr patcher-pair) (- new-text-size (car patcher-pair))))
list-of-patcher-pairs))
(define (make-block-f-ref-patchers! new-text-size list-of-unres-lists env)
(for-each
(lambda (unres-list)
(let ((exists (let iter ((rst env))
(cond ((null? rst) #f)
((and (eq? (car unres-list)
(sassy-symbol-name (car rst)))
(eq? (cadddr unres-list)
(sassy-symbol-scope (car rst))))
(car rst))
(else (iter (cdr rst)))))))
(when exists
(sassy-symbol-unres-set!
exists
(cons ((caddr unres-list)
(- new-text-size (cadr unres-list)))
(sassy-symbol-unres exists))))))
list-of-unres-lists))
(define (make-forward-ref-patchers! new-text-size list-of-unres-lists)
; unres-list: car = symbol, cadr flipped eip, caddr = patcher-generator
; cadddr scope
(for-each
(lambda (unres-list)
(let ((scope (cadddr unres-list)))
(when (or (case scope
((import local global) #t)
(else #f))
(not (cadddr unres-list)))
(sassy-symbol-set!
outp (car unres-list)
`(unres ,((caddr unres-list) (- new-text-size
(cadr unres-list))))))))
list-of-unres-lists))
(define the-assertions
(alist->hash-table
'((o! . 0) (no! . 1)
(b! . 2) (c! . 2) (nae! . 2) (nb! . 3) (nc! . 3) (ae! . 3)
(e! . 4) (z! . 4) (ne! . 5) (nz! . 5)
(be! . 6) (na! . 6) (nbe! . 7) (a! . 7)
(s! . 8) (ns! . 9)
(p! . 10) (pe! . 10) (np! . 11) (po! . 11)
(l! . 12) (nge! . 12) (nl! . 13) (ge! . 13)
(le! . 14) (ng! . 14) (g! . 15) (nle! . 15))))
(define (assertion? x)
(hash-table-ref the-assertions x (lambda () #f)))
(define (flip x) ; flip an assertion cc-code
(if (even? x) (+ x 1) (- x 1)))
(define get-assert-name
(let ((the-names '#(jo jno jb jnb je jne jbe jnbe
js jns jp jpo jl jnl jle jg)))
(lambda (cc)
(vector-ref the-names cc))))
(define (gen-short-assert cc amount)
(let ((stack (t-text textb)))
(push-stack-push stack (cons (+ #x70 cc) (integer->byte-list amount 1)))
(push-stack-size stack)))
(define (gen-near-assert cc amount)
(let ((stack (t-text textb)))
(push-stack-push stack (cons #x0f (cons (+ #x80 cc)
(integer->byte-list
amount
current-byte-size))))
(push-stack-size stack)))
(define (gen-assert cc amount)
(if (s-byte amount)
(gen-short-assert cc amount)
(gen-near-assert cc amount)))
(define (gen-short-jmp amount)
(let ((stack (t-text textb)))
(push-stack-push stack (cons #xeb (integer->byte-list amount 1)))
(push-stack-size stack)))
(define (gen-near-jmp amount)
(let ((stack (t-text textb)))
(push-stack-push stack (cons #xe9 (integer->byte-list
amount
current-byte-size)))
(push-stack-size stack)))
(define (gen-jmp amount)
(if (s-byte amount)
(gen-short-jmp amount)
(gen-near-jmp amount)))
; Eeek!! Optimize cc-branches for size. May have to rework to work
; nicely with P4 static branch prediction.
(define (gen-opt-jcc cc win lose)
(let* ((current (push-stack-size (t-text textb))))
(cond ((and (number? win) (number? lose))
(let ((win-rel (- current win))
(lose-rel (- current lose)))
(cond ((and (zero? win-rel) (zero? lose-rel)) win)
((= win lose) (gen-jmp win-rel))
((zero? lose-rel) (gen-assert cc win-rel))
((zero? win-rel) (gen-assert (flip cc) lose-rel))
((and (s-byte lose-rel) (s-byte (+ win-rel 2)))
(gen-short-jmp lose-rel)
(gen-short-assert cc (+ win-rel 2)))
((and (s-byte win-rel) (s-byte (+ lose-rel 2)))
(gen-short-jmp win-rel)
(gen-short-assert (flip cc) (+ lose-rel 2)))
((s-byte (+ lose-rel rel-adjust))
(gen-near-jmp win-rel)
(gen-short-assert (flip cc) (+ lose-rel rel-adjust)))
(else (gen-opt-jmp lose win lose)
(gen-assert
cc (- (push-stack-size (t-text textb)) win))))))
((and (or (symbol win) (number? win))
(or (symbol lose) (number? lose)))
(cond ((equal? win lose) (emit-direct `(jmp ,win)
win lose textb outp))
((and (symbol win) (symbol lose))
(emit-direct `(jmp ,lose) win lose textb outp)
(emit-direct `(,(get-assert-name cc) ,win)
win lose textb outp))
((and (symbol win) (= lose current))
(emit-direct `(,(get-assert-name cc) ,win)
win lose textb outp))
((symbol win)
(emit-direct `(jmp ,win) win lose textb outp)
(gen-assert (flip cc) (+ (- current lose) rel-adjust)))
((and (symbol lose) (= win current))
(emit-direct `(,(get-assert-name (flip cc)) ,lose)
win lose textb outp))
(else (emit-direct `(jmp ,lose) win lose textb outp)
(gen-assert cc (+ (- current win) rel-adjust)))))
((number? win)
(emit-direct lose win lose textb outp)
(gen-assert cc (- (push-stack-size (t-text textb)) win)))
((number? lose)
(emit-direct win win lose textb outp)
(gen-assert (flip cc) (- (push-stack-size (t-text textb)) lose)))
((symbol win)
(emit-direct lose win lose textb outp)
(emit-direct `(,(get-assert-name cc) ,win)
win lose textb outp))
((symbol lose)
(emit-direct win win lose textb outp)
(emit-direct `(,(get-assert-name (flip cc)) ,lose)
win lose textb outp))
((equal? win lose) (emit-direct win win lose textb outp))
(else (emit-direct lose win lose textb outp)
(let ((new-lose (push-stack-size (t-text textb))))
(emit-direct win win lose textb outp)
(gen-assert (flip cc) (- (push-stack-size (t-text textb))
new-lose)))))))
(define (gen-opt-jmp to win lose)
(cond ((symbol to) => (lambda (x)
(emit-direct2 'jmp (opcode? 'jmp) (list x)
win lose textb outp)))
(else (let ((current (push-stack-size (t-text textb))))
(if (= to current)
current
(gen-jmp (- current to)))))))
; Iterative closure to get the backward branches right. Same with
; handle-while. Looks good on the page, but can be exponential in
; time when there are inner loops. Maybe a user option should
; exist to do this Baker's way (one pass only), but with no jump
; size optimization. Maybe it won't matter anyway too much. TBD.
(define (handle-iter exp win lose)
(let ((reset! (t-save! textb))
(old-env (sassy-symbol-table outp)))
(let iter ((new (compile exp
(+ 2 (push-stack-size (t-text textb)))
lose))
(count (+ 3 (push-stack-size (t-text textb)))))
(if (not (= count new))
(begin (reset!)
(sassy-symbol-table-set! outp old-env)
(iter (compile `(with-win $win ,exp) new lose)
new))
new))))
(define (handle-while test body win lose)
(let ((reset! (t-save! textb))
(old-env (sassy-symbol-table outp)))
(let iter ((new (compile body
(compile `(mark ,test)
(+ 2 (push-stack-size
(t-text textb)))
win)
lose))
(count (+ 3 (push-stack-size (t-text textb)))))
(if (not (= count new))
(begin (reset!)
(sassy-symbol-table-set! outp old-env)
(iter (compile body
(compile `(mark ,test) new win)
lose)
new))
(compile '(leap $win) new lose)))))
; The core dispatch procedure - this is where the Comfy65 based
; stuff happens.
(define (compile exp win lose)
(define (symbol2 x)
(let ((z (symbol x)))
(and z (not (memq z '($win $lose))) z)))
(define (branch-or-compile e)
(if (and (pair? e)
(or (eqv? (car e) 'jmp)
(eqv? (car e) 'ret)))
(emit-direct e win lose textb outp)
(really-compile e)))
(define really-compile
(meta-lambda
(or
(and opcode? __ (lambda (opcode . rands)
(and (or (symbol win)
(not (= win (push-stack-size
(t-text textb)))))
(gen-opt-jmp win win lose))
(emit-direct2 (car exp)
opcode rands win lose textb outp)))
(and 'seq (or (begin win) ; allowed to write (seq)
(and ? (lambda (tail) (really-compile tail)))
(and __ (lambda body
(compile (car body)
(really-compile `(seq ,@(cdr body)))
lose)))))
(and 'begin
(or (begin win)
(and ? (lambda (tail) (really-compile tail)))
(and __ (lambda body
(let ((w (really-compile `(begin ,@(cdr body)))))
(compile (car body) w w))))))
(and 'inv ? (lambda (e) (compile e lose win)))
(and 'if ? ? ? (lambda (test conseq altern)
(let* ((loser (really-compile altern))
(winner (really-compile conseq)))
(compile test winner loser))))
(and ,@assertion? (lambda (cc) (gen-opt-jcc cc win lose)))
(and ,@'$eip (begin (push-stack-size (t-text textb))))
(and ,@'$win (begin win))
(and ,@'$lose (begin lose))
(and 'iter ? (lambda (loop) (handle-iter loop win lose)))
(and 'while ? ? (lambda (test body) (handle-while test body win lose)))
(and 'label valid-label __
(lambda (label . body)
(sassy-symbol-def-error outp label)
(let ((scope (sassy-symbol-scope
(sassy-symbol-set! outp label '(section text)))))
(really-compile (cons 'begin body))
(let ((pnt (push-stack-size (t-text textb))))
(push-t-label! textb (list label scope pnt))
pnt))))
(and 'locals pair? __
(lambda (locals . body)
(let ((reset! (setup-locals locals outp
(lambda (new-sym)
(push-t-env! textb new-sym)))))
(really-compile (cons 'begin body))
(reset!)
(push-stack-size (t-text textb)))))
(and 'esc pair? ? (lambda (list-of-escapes body)
(really-compile body)
(for-each (lambda (escape)
(emit-direct
escape win lose textb outp))
(reverse list-of-escapes))
(push-stack-size (t-text textb))))
(and 'mark ? (lambda (body) (let ((z (really-compile body)))
(push-t-mark! textb z)
z)))
(and 'leap ? (lambda (body) (let ((z (really-compile body)))
(or (pop-t-mark! textb) z))))
(and 'with-win
(or (and ? (lambda (only-one)
(really-compile `(with-win ,only-one (seq)))))
(and assertion? ?
(lambda (cc body)
(compile body (gen-opt-jcc cc win lose) lose)))
(and symbol2 ? (lambda (new-win body)
(compile body new-win lose)))
(and ? ? (lambda (win-b body)
(compile body (branch-or-compile win-b) lose)))))
(and 'with-lose
(or (and ? (lambda (only-one)
(really-compile `(with-lose ,only-one (seq)))))
(and assertion? ?
(lambda (cc body)
(compile body win (gen-opt-jcc cc win lose))))
(and symbol2 ? (lambda (new-lose body)
(compile body win new-lose)))
(and ? ? (lambda (lose-b body)
(compile body win (branch-or-compile lose-b))))))
(and 'with-win-lose
(or (and ? ? (lambda (one two)
(really-compile `(with-win-lose ,one ,two (seq)))))
(and assertion?
(or (and assertion? ?
(lambda (cc1 cc2 body)
(let ((new-lose (gen-opt-jcc cc2 win lose)))
(compile body (gen-opt-jcc cc1 win lose)
new-lose))))
(and symbol2 ?
(lambda (cc new-lose body)
(compile body (gen-opt-jcc cc win lose)
new-lose)))
(and ? ?
(lambda (cc lose-b body)
(let ((new-lose (branch-or-compile lose-b)))
(compile body (gen-opt-jcc cc win lose)
new-lose))))))
(and symbol2
(or (and assertion? ?
(lambda (new-win cc body)
(compile body new-win
(gen-opt-jcc cc win lose))))
(and symbol2 ? (lambda (new-win new-lose body)
(compile body new-win new-lose)))
(and ? ? (lambda (new-win lose-b body)
(compile body new-win
(branch-or-compile lose-b))))))
(and ?
(or (and assertion? ?
(lambda (win-b cc body)
(let ((new-lose (gen-opt-jcc cc win lose)))
(compile body (branch-or-compile win-b)
new-lose))))
(and symbol2 ? (lambda (win-b new-lose body)
(compile body
(branch-or-compile win-b)
new-lose)))
(and ? ?
(lambda (win-b lose-b body)
(let ((new-lose (branch-or-compile lose-b)))
(compile body (branch-or-compile win-b)
new-lose))))))))
(else (lambda (i) (error "sassy: bad text item" i))))))
(really-compile exp))
(let ((win (compile text-item 0 0)))
(when (not (= win (push-stack-size (t-text textb)))) ; in case there was
(gen-opt-jmp win win 0)) ; a top-level "leap"
(let ((new-text-size (+ (sassy-text-size outp)
(sassy-text-org outp)
(push-stack-size (t-text textb)))))
(fix-relocations! new-text-size (t-reloc textb))
(fix-backward-refs! new-text-size (t-res textb))
(make-forward-ref-patchers! new-text-size (t-unres textb))
(make-block-f-ref-patchers! new-text-size (t-unres textb) (t-env textb))
(fix-body-labels! new-text-size (t-label textb))
(fix-block-labels! new-text-size (t-label textb) (t-env textb))
(push-stack-append! (sassy-text-stack outp) (t-text textb))
(push-stack-size (t-text textb)))))