mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +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)))))

3
test-suite/standalone/Makefile.am
View file

@ -154,4 +154,7 @@ EXTRA_DIST += test-with-guile-module.c test-scm-with-guile.c
endif
check_SCRIPTS += test-sassy
TESTS += test-sassy
EXTRA_DIST += ${check_SCRIPTS}

2
test-suite/standalone/sassy/tests/aa Normal file
View file

@ -0,0 +1,2 @@
<EFBFBD>
<EFBFBD>

5
test-suite/standalone/sassy/tests/aa.asm Normal file
View file

@ -0,0 +1,5 @@
BITS 32
section .text
foo:
aad
aam 9

5
test-suite/standalone/sassy/tests/aa.scm Normal file
View file

@ -0,0 +1,5 @@
(
(aad)
(aam 9)
)

BIN
test-suite/standalone/sassy/tests/all Normal file
View file

Binary file not shown.

870
test-suite/standalone/sassy/tests/all.asm Normal file
View file

@ -0,0 +1,870 @@
BITS 32
section .text
foo:
loop foo
loope foo, cx
loopz foo, ecx
loopne foo
loopnz foo, cx
jcxz foo
jecxz foo
call dword 0
call word 0
call dword 1000:1000
call word 1000:1000
call far dword [ecx]
call far word [ecx]
call ecx
call dword [ecx]
call cx
call word [ecx]
jmp dword 0
jmp near dword 0
jmp word 0
jmp near word 0
jmp dword 1000:1000
jmp word 1000:1000
jmp far dword [ecx]
jmp far word [ecx]
jmp ecx
jmp dword [ecx]
jmp cx
jmp word [ecx]
add eax, [ecx]
add eax, [ebp]
add eax, [esp]
add eax, [100]
add eax, [1600]
add eax, [ecx*1]
add eax, [ecx*2]
add eax, [ecx*4]
add eax, [ecx*8]
add eax, [ebp*1]
add eax, [ebp*2]
add eax, [ebp*4]
add eax, [ebp*8]
add eax, [ecx+100]
add eax, [ecx+1600]
add eax, [ebp+100]
add eax, [ebp+1600]
add eax, [esp+100]
add eax, [esp+1600]
add eax, [100+ecx]
add eax, [1600+ecx]
add eax, [100+ebp]
add eax, [1000+ebp+600]
add eax, [100+esp]
add eax, [1600+esp]
add eax, [ecx+edx*1]
add eax, [ebp*1+ecx]
add eax, [ecx+edx*2]
add eax, [ebp*2+ecx]
add eax, [ecx+edx*4]
add eax, [ebp*4+ecx]
add eax, [ecx+edx*8]
add eax, [ecx+ebp*8]
add eax, [edx*1+ebp]
add eax, [ebp+ebp*1]
add eax, [ebp+edx*2]
add eax, [ebp+ebp*2]
add eax, [ebp+edx*4]
add eax, [ebp*4+ebp]
add eax, [ebp+edx*8]
add eax, [ebp+ebp*8]
add eax, [esp+edx*1]
add eax, [esp+ebp*1]
add eax, [esp+edx*2]
add eax, [ebp*2+esp]
add eax, [esp+edx*4]
add eax, [esp+ebp*4]
add eax, [esp+edx*8]
add eax, [esp+ebp*8]
add eax, [ecx*1+100]
add eax, [ecx*2+100]
add eax, [100+ecx*4]
add eax, [ecx*8+100]
add eax, [100+ebp*1]
add eax, [ebp*2+100]
add eax, [100+ebp*4]
add eax, [ebp*8+100]
add eax, [1600+ecx*1]
add eax, [ecx*2+1600]
add eax, [ecx*4+1600]
add eax, [1600+ecx*8]
add eax, [ebp*1+1600]
add eax, [1600+ebp*2]
add eax, [ebp*4+1600]
add eax, [ebp*8+1600]
add eax, [ecx+100+edx*1]
add eax, [ecx+edx*2+100]
add eax, [edx*4+ecx+100]
add eax, [ecx+edx*8+100]
add eax, [ecx+ebp*1+100]
add eax, [ecx+ebp*2+100]
add eax, [ecx+ebp*4+100]
add eax, [100+ecx+ebp*8]
add eax, [ebp+edx*1+100]
add eax, [ebp+edx*2+100]
add eax, [ebp+edx*4+100]
add eax, [ebp+edx*8+100]
add eax, [ebp+ebp*1+100]
add eax, [100+ebp*2+ebp]
add eax, [ebp+ebp*4+100]
add eax, [ebp+ebp*8+100]
add eax, [esp+edx*1+100]
add eax, [esp+edx*2+100]
add eax, [esp+edx*4+100]
add eax, [esp+edx*8+100]
add eax, [esp+ebp*1+100]
add eax, [esp+ebp*2+100]
add eax, [esp+ebp*4+100]
add eax, [esp+ebp*8+100]
add eax, [ecx+edx*1+1600]
add eax, [ecx+edx*2+1600]
add eax, [ecx+edx*4+1600]
add eax, [ecx+edx*8+1600]
add eax, [ecx+ebp*1+1600]
add eax, [ecx+ebp*2+1600]
add eax, [ecx+ebp*4+1600]
add eax, [ecx+ebp*8+1600]
add eax, [ebp+edx*1+1600]
add eax, [ebp+edx*2+1600]
add eax, [ebp+edx*4+1600]
add eax, [ebp+edx*8+1600]
add eax, [ebp+ebp*1+1600]
add eax, [ebp+ebp*2+1600]
add eax, [ebp+ebp*4+1600]
add eax, [ebp+ebp*8+1600]
add eax, [esp+edx*1+1600]
add eax, [esp+edx*2+1600]
add eax, [esp+edx*4+1600]
add eax, [esp+edx*8+1600]
add eax, [esp+ebp*1+1600]
add eax, [esp+ebp*2+1600]
add eax, [esp+ebp*4+1600]
add eax, [esp+ebp*8+1600]
aaa
aas
cbw
cdq
clc
cld
cli
clts
cmc
cmpsb
cmpsw
cmpsd
cpuid
cwde
cwd
daa
das
hlt
insb
insw
insd
int3
into
invd
iret
iretw
iretd
lahf
leave
lodsb
lodsw
lodsd
movsb
movsw
movsd
nop
outsb
outsw
outsd
popa
popaw
popad
popf
popfw
popfd
pusha
pushaw
pushad
pushf
pushfw
pushfd
rdmsr
rdpmc
rdtsc
rsm
sahf
scasb
scasw
scasd
stc
std
sti
stosb
stosw
stosd
ud2
wbinvd
wrmsr
xlat
xlatb
sysenter
sysexit
adc al, 100
add ax, 1000
and eax, 50000
cmp bl, 100
sbb cx, word 1000
xor edx, dword 50000
add cx, byte 100
cmp edx, byte 100
adc dword [eax+edx*4+100], dword 50000
or dword [edx], byte 100
sub word [eax+edx], word 1000
and word [eax+edx], byte 100
or byte [eax+edx*4+100], byte 100
sbb bl, bl
sub [ebx], bl
xor cx, cx
adc [eax+edx], cx
add edx, edx
and [eax+edx*4+100], edx
cmp bl, [ebx]
or cx, [eax+edx]
sbb edx, [eax+edx*4+100]
bt si, si
btc [100+200+edx], si
btr [8*eax], edi
bts edi, edi
bt si, 9
btc word [100+200+edx], byte 9
btr edi, 9
bts dword [8*eax], byte 9
rcl ebp, 1
rcr dword [eax+1000], 1
seto ah
setno [eax+esi*1]
setb ah
setc [eax+esi*1]
setnae ah
setnb [eax+esi*1]
setnc ah
setae [eax+esi*1]
sete ah
setz [eax+esi*1]
setne ah
setnz [eax+esi*1]
setbe ah
setna [eax+esi*1]
seta ah
setnbe [eax+esi*1]
sets ah
setns [eax+esi*1]
setp ah
setpe [eax+esi*1]
setnp ah
setpo [eax+esi*1]
setl ah
setnge [eax+esi*1]
setge ah
setnl [eax+esi*1]
setle ah
setng [eax+esi*1]
setnle ah
setg [eax+esi*1]
cmovo cx, bx
cmovno bx, [edx+esi*4]
cmovb edx, eax
cmovc ebp, [esp+eax*4]
cmovnae cx, bx
cmovnb bx, [edx+esi*4]
cmovnc edx, eax
cmovae ebp, [esp+eax*4]
cmove cx, bx
cmovz bx, [edx+esi*4]
cmovne edx, eax
cmovnz ebp, [esp+eax*4]
cmovbe cx, bx
cmovna bx, [edx+esi*4]
cmova edx, eax
cmovnbe ebp, [esp+eax*4]
cmovs cx, bx
cmovns bx, [edx+esi*4]
cmovp edx, eax
cmovpe ebp, [esp+eax*4]
cmovnp cx, bx
cmovpo bx, [edx+esi*4]
cmovl edx, eax
cmovnge ebp, [esp+eax*4]
cmovge cx, bx
cmovnl bx, [edx+esi*4]
cmovle edx, eax
cmovng ebp, [esp+eax*4]
cmovnle cx, bx
cmovg bx, [edx+esi*4]
dec dword [eax]
inc word [eax]
dec byte [eax]
inc ch
dec esp
inc dx
div dword [ebx]
idiv word [ebx]
mul byte [ebx]
neg edi
not edi
div edi
lds edi, [esi]
les di, [esi]
lea edi, [esi]
lfs di, [esi]
lgs edi, [esi]
lss di, [esi]
movsx ebp, ax
movzx ebp, word [edi]
movsx ebp, al
movzx ebp, byte [edi]
movsx bp, ah
movzx bp, [edi]
bsf bx, ax
bsr bx, [eax]
lar ebx, eax
lsl ebx, [eax]
invlpg [200+8*esi+esp+100]
lgdt [200+8*esi+esp+100]
sgdt [200+8*esi+esp+100]
lidt [200+8*esi+esp+100]
sidt [200+8*esi+esp+100]
lldt sp
sldt [esp]
lmsw sp
smsw [esp]
ltr sp
str [esp]
verr sp
verw [esp]
aad
aam 9
ret
retn 1000
retf
shld bx, ax, 9
shrd [ebx], ax, 9
shld ebx, eax, 9
shrd [ebx], eax, 9
shld bx, ax, cl
shrd [ebx], ax, cl
shld ebx, eax, cl
shrd [ebx], eax, cl
cmpxchg al, bh
xadd [eax], bh
cmpxchg ax, bx
xadd [eax], bx
cmpxchg eax, ebx
xadd [eax], ebx
arpl cx, bx
arpl [ecx], bx
bound ax, [edi]
bound eax, [edi]
bswap edx
cmpxchg8b [edx+ecx]
enter 1000, 100
xchg ax, bx
xchg bx, ax
xchg eax, ebx
xchg ebx, eax
xchg al, ah
xchg [ebx], ah
xchg cx, bx
xchg [ecx], bx
xchg ecx, ebx
xchg [ecx], ebx
xchg al, [edi]
xchg ax, [edi]
xchg eax, [edi]
in al, 9
in ax, 9
in eax, 9
in al, dx
in ax, dx
in eax, dx
out 9, al
out 9, ax
out 9, eax
out dx, al
out dx, ax
out dx, eax
int 128
pop cx
pop ecx
pop dword [ecx]
pop word [ecx]
pop ds
pop es
pop ss
pop fs
pop gs
push cx
push edx
push dword 100
push word 100
push byte 100
push word [esi]
push dword [esi]
push cs
push ds
push es
push ss
push fs
push gs
imul ax, bx, word 100
imul ax, [ebx], word 100
imul ax, bx, byte 100
imul ax, [ebx], byte 100
imul eax, ebx, dword 100
imul eax, [ebx], dword 100
imul eax, ebx, byte 100
imul eax, [ebx], byte 100
imul eax, dword 100
imul eax, byte 100
imul ax, word 100
imul ax, byte 100
imul ax, bx
imul ax, [ebx]
imul eax, ebx
imul eax, [ebx]
imul al
imul byte [eax]
imul ax
imul word [eax]
imul eax
imul dword [eax]
test al, 9
test ax, 9
test eax, 9
test bl, cl
test [ebx], cl
test bx, cx
test [ebx], cx
test ebx, ecx
test [ebx], ecx
test bl, 9
test dword [ebx], 9
test bx, 9
test word [ebx], 9
test ebx, 9
test byte [ebx], 9
mov bl, cl
mov [edx], cl
mov bx, dx
mov [esi], dx
mov ebx, edi
mov [eax], edi
mov bl, cl
mov bl, [edx]
mov bx, dx
mov bx, [esi]
mov ebx, edi
mov ebx, [eax]
mov bl, 9
mov bx, 9
mov ebx, 9
mov [edx], byte 9
mov [esi], word 9
mov [eax], dword 9
mov al, [9]
mov ax, [9]
mov eax, [9]
mov [9], al
mov [9], ax
mov [9], eax
mov bx, ds
mov [esi], ss
mov ebx, fs
mov [eax], es
mov gs, dx
mov ds, [esi]
mov fs, edi
mov ss, [eax]
mov ecx, cr2
mov ecx, dr1
mov cr0, edx
mov dr0, edx
jo near dword 0
jno near word 0
jb 0
jc near dword 0
jnae near word 0
jnb 0
jnc near dword 0
jae near word 0
je 0
jz near dword 0
jne near word 0
jnz 0
jbe near dword 0
jna near word 0
ja 0
jnbe near dword 0
js near word 0
jns 0
jp near dword 0
jpe near word 0
jnp 0
jpo near dword 0
jl near word 0
jnge 0
jge near dword 0
jnl near word 0
jle 0
jng near dword 0
jnle near word 0
jg 0
rep insd
rep outsw
rep lodsb
rep stosd
rep movsb
repe cmpsb
repz cmpsd
repne scasd
repnz scasb
lock add byte [eax], 1
lock dec dword [edx]
lock xor [ecx], ecx
fld1
fldl2t
fldl2e
fldpi
fldlg2
fldln2
fldz
fsin
fcos
fsincos
fptan
fpatan
f2xm1
fyl2x
fyl2xp1
fincstp
fdecstp
finit
fninit
fclex
fnclex
fwait
wait
fnop
fcompp
fucompp
ftst
fxam
fprem
fprem1
fabs
fchs
frndint
fscale
fsqrt
fxtract
fadd dword [eax]
fsub qword [ebx]
fsubr st0, st4
fmul st7, st0
fdiv dword [eax]
fdivr qword [ebx]
fdivrp st2, st0
fdivp st2, st0
fmulp st2, st0
fsubp st3, st0
fsubrp st2, st0
faddp st4, st0
fimul dword [eax]
fiadd word [ebx]
fidiv word [ebx]
fidivr dword [eax]
fisub word [ebx]
fisubr dword [eax]
fcmovb st0, st2
fcmove st0, st3
fcmovbe st0, st4
fcmovu st0, st5
fcmovnb st0, st6
fcmovne st0, st7
fcmovnbe st0, st1
fcmovnu st0, st2
fxch
fucom st3
fld tword [eax]
fstp qword [ebx]
fld dword [ecx]
fstp st4
fst dword [edx]
fst qword [ebx]
fst st3
fild word [ebx]
fistp dword [ebx]
fild qword [ebx]
fist word [ecx]
ficom dword [ecx]
ficomp word [ecx]
fcomp dword [edi]
fcom qword [edi]
fcomp st0
fcomi st0, st7
fcomip st0, st6
fucomi st0, st5
fucomip st0, st4
fbld tword [eax]
fbstp tword [eax]
fstcw word [ebx]
fldcw word [ebx]
fnstcw word [ebx]
fstenv [eax]
fnstenv [ebx]
ffree st2
fldenv [edx]
fsave [edx]
fnsave [edx]
frstor [edx]
fxsave [edx]
fxrstor [edx]
fstsw ax
fstsw word [ebx]
fnstsw ax
fnstsw word [ebx]
emms
movd mm1, ebx
movd mm1, [edx]
movd ebx, mm1
movd [edx], mm1
movd xmm0, ebx
movd xmm0, [edx]
movd ebx, xmm0
movd [edx], xmm0
movq mm1, mm0
movq mm1, [edx]
movq mm0, mm1
movq [edx], mm1
movq xmm0, xmm1
movq xmm0, [edx]
movq xmm1, xmm0
movq [edx], xmm0
pand mm0, mm1
pandn mm1, [edx]
por xmm2, xmm3
pxor xmm4, [ecx]
packsswb mm0, mm1
packssdw mm1, [edx]
packuswb xmm2, xmm3
punpckhbw xmm4, [ecx]
punpckhwd mm0, mm1
punpckhdq mm1, [edx]
paddb xmm2, xmm3
paddw xmm4, [ecx]
paddd mm0, mm1
paddsb mm1, [edx]
paddsw xmm2, xmm3
paddusb xmm4, [ecx]
paddusw mm0, mm1
psubb mm1, [edx]
psubw xmm2, xmm3
psubd xmm4, [ecx]
psubsb mm0, mm1
psubsw mm1, [edx]
psubusb xmm2, xmm3
psubusw xmm4, [ecx]
pmullw mm0, mm1
pmulhw mm1, [edx]
pmaddwd xmm2, xmm3
pcmpeqb xmm4, [ecx]
pcmpeqw mm0, mm1
pcmpeqd mm1, [edx]
pcmpgtb xmm2, xmm3
pcmpgtw xmm4, [ecx]
pcmpgtd mm0, mm1
punpcklbw mm2, mm3
punpcklwd mm4, [ebx]
punpckldq xmm5, xmm6
punpcklbw xmm7, [edx]
psrlw mm7, mm6
psrld mm5, [edx]
psrlq xmm7, xmm6
psllw xmm5, [edx]
pslld mm4, 100
psllq xmm4, 100
psraw mm7, mm6
psrad mm5, [edx]
movaps xmm5, xmm4
movups xmm3, [edx]
movaps [edx], xmm2
movups xmm5, xmm4
addps xmm3, xmm0
subps xmm0, [edx]
mulps xmm3, xmm0
divps xmm0, [edx]
rcpps xmm3, xmm0
sqrtps xmm0, [edx]
rsqrtps xmm3, xmm0
maxps xmm0, [edx]
minps xmm3, xmm0
andps xmm0, [edx]
andnps xmm3, xmm0
orps xmm0, [edx]
xorps xmm3, xmm0
unpckhps xmm0, [edx]
unpcklps xmm3, xmm0
addss xmm0, xmm1
subss xmm0, [eax]
mulss xmm0, xmm1
divss xmm0, [eax]
rcpss xmm0, xmm1
sqrtss xmm0, [eax]
rsqrtss xmm0, xmm1
maxss xmm0, [eax]
minss xmm0, xmm1
comiss xmm0, [eax]
ucomiss xmm0, xmm1
pavgb mm0, mm1
pavgw mm2, [edx]
pmaxub xmm3, xmm4
pmaxsw xmm5, [edx]
pminub mm0, mm1
pminsw mm2, [edx]
pmulhuw xmm3, xmm4
psadbw xmm5, [edx]
movhps xmm0, [edx]
movlps [edx], xmm6
movhlps xmm0, xmm1
movlhps xmm1, xmm0
shufps xmm0, xmm6, 10
cmpps xmm5, [ecx], 20
prefetcht0 [eax]
prefetcht1 [eax]
prefetcht2 [eax]
prefetchnta [eax]
sfence
movntps [ecx], xmm3
maskmovq mm3, mm4
movntq [ebx], mm7
pmovmskb eax, mm0
pmovmskb ecx, xmm5
pshufw mm0, mm1, 40
pshufw mm0, [ebx], 30
ldmxcsr [ebx]
stmxcsr [edx]
pinsrw mm1, eax, 4
pinsrw mm0, [edx], 5
pinsrw xmm4, ebx, 6
pinsrw xmm3, [ecx], 7
pextrw edx, mm3, 28
pextrw esi, mm0, 14
cvtsi2ss xmm3, edi
cvtsi2ss xmm3, [edi]
cvtpi2ps xmm4, mm2
cvtpi2ps xmm4, [edi+100]
movss xmm1, [edx]
movss xmm1, xmm6
movss [edx], xmm3
movmskps ebx, xmm3
cmpss xmm3, xmm4, 10
cmpss xmm3, [edx], 20
cvttss2si ebx, xmm3
cvtss2si eax, [ecx]
cvtps2pi mm3, xmm1
cvttps2pi mm4, [edx]
movapd xmm0, xmm1
movupd xmm2, [edx]
movdqa [eax], xmm3
movdqu xmm0, xmm1
movhpd xmm0, [ecx]
movmskpd ebx, xmm4
movlpd [ecx], xmm0
movsd xmm5, xmm6
movsd xmm7, [esi]
movsd [esi], xmm7
addpd xmm0, xmm1
subpd xmm2, [ecx]
mulpd xmm0, xmm1
divpd xmm2, [ecx]
sqrtpd xmm0, xmm1
maxpd xmm2, [ecx]
minpd xmm0, xmm1
andpd xmm2, [ecx]
andnpd xmm0, xmm1
orpd xmm2, [ecx]
xorpd xmm0, xmm1
unpckhpd xmm2, [ecx]
unpcklpd xmm0, xmm1
cvtpd2dq xmm2, [ecx]
cvttpd2dq xmm0, xmm1
cvtdq2ps xmm2, [ecx]
cvtps2dq xmm0, xmm1
cvttps2dq xmm2, [ecx]
cvtpd2ps xmm0, xmm1
punpckhqdq xmm2, [ecx]
punpcklqdq xmm0, xmm1
addsd xmm2, xmm3
subsd xmm4, [edi]
mulsd xmm2, xmm3
divsd xmm4, [edi]
maxsd xmm2, xmm3
minsd xmm4, [edi]
sqrtsd xmm2, xmm3
comisd xmm4, [edi]
ucomisd xmm2, xmm3
cvtdq2pd xmm4, [edi]
cvtps2pd xmm2, xmm3
cvtsd2ss xmm4, [edi]
cmppd xmm0, xmm1, 10
shufpd xmm2, [ebx], 20
pshuflw xmm0, xmm1, 10
pshufhw xmm2, [ebx], 20
pshufd xmm0, xmm1, 10
cmpsd xmm4, xmm5, 20
cmpsd xmm6, [eax], 30
cvttpd2pi mm0, xmm1
cvtpd2pi mm0, [ebp]
pause
lfence
mfence
clflush [ebx]
pmuludq mm0, mm1
paddq mm0, [edx]
psubq xmm3, xmm1
pmuludq xmm3, [edx]
maskmovdqu xmm1, xmm2
movnti [edx], eax
movq2dq xmm3, mm4
movdq2q mm5, xmm7
movntpd [eax], xmm3
movntdq [ebx], xmm4
pslldq xmm3, 20
psrldq xmm3, 20
cvtpi2pd xmm3, mm4
cvtpi2pd xmm3, [ecx]
cvtss2sd xmm3, xmm6
cvtss2sd xmm3, [edx]
cvtsd2si ecx, xmm3
cvttsd2si edx, [edx]
cvtsi2sd xmm3, eax
cvtsi2sd xmm3, [eax]
monitor
mwait
lddqu xmm0, [edx]
movddup xmm0, xmm1
addsubps xmm0, xmm1
addsubpd xmm2, [edx]
haddps xmm0, xmm1
hsubps xmm2, [edx]
haddpd xmm0, xmm1
hsubpd xmm2, [edx]
movshdup xmm0, xmm1
movsldup xmm2, [edx]
movddup xmm0, [edx]

BIN
test-suite/standalone/sassy/tests/alu Normal file
View file

Binary file not shown.

25
test-suite/standalone/sassy/tests/alu.asm Normal file
View file

@ -0,0 +1,25 @@
BITS 32
section .text
foo:
adc al, 100
add ax, 1000
and eax, 50000
cmp bl, 100
or cx, word 1000
sbb edx, dword 50000
sub cx, byte 100
xor edx, byte 100
adc dword [100+eax+edx*4], dword 50000
add dword [edx], byte 100
and word [eax+edx], word 1000
cmp word [eax+edx], byte 100
or byte [100+eax+edx*4], byte 100
sbb bl, bl
sub [ebx], bl
xor cx, cx
adc [eax+edx], cx
add edx, edx
and [100+eax+edx*4], edx
cmp bl, [ebx]
or cx, [eax+edx]
sbb edx, [100+eax+edx*4]

24
test-suite/standalone/sassy/tests/alu.scm Normal file
View file

@ -0,0 +1,24 @@
(
(adc al 100)
(add ax 1000)
(and eax 50000)
(cmp bl 100)
(or cx (word 1000))
(sbb edx (dword 50000))
(sub cx (byte 100))
(xor edx (byte 100))
(adc (dword (& eax (* edx 4) 100)) (dword 50000))
(add (dword (& edx)) (byte 100))
(and (word (& eax edx)) (word 1000))
(cmp (word (& eax edx)) (byte 100))
(or (byte (& eax (* edx 4) 100)) (byte 100))
(sbb bl bl)
(sub (& ebx) bl)
(xor cx cx)
(adc (& eax edx) cx)
(add edx edx)
(and (& eax (* edx 4) 100) edx)
(cmp bl (& ebx))
(or cx (& eax edx))
(sbb edx (& eax (* edx 4) 100))
)

BIN
test-suite/standalone/sassy/tests/alu16 Normal file
View file

Binary file not shown.

25
test-suite/standalone/sassy/tests/alu16.asm Normal file
View file

@ -0,0 +1,25 @@
BITS 16
section .text
foo:
adc al, 100
add ax, 1000
and eax, 50000
cmp bl, 100
or cx, word 1000
sbb edx, dword 50000
sub cx, byte 100
xor edx, byte 100
adc dword [100+eax+edx*4], dword 50000
add dword [edx], byte 100
and word [eax+edx], word 1000
cmp word [eax+edx], byte 100
or byte [100+eax+edx*4], byte 100
sbb bl, bl
sub [ebx], bl
xor cx, cx
adc [eax+edx], cx
add edx, edx
and [100+eax+edx*4], edx
cmp bl, [ebx]
or cx, [eax+edx]
sbb edx, [100+eax+edx*4]

1
test-suite/standalone/sassy/tests/brt Normal file
View file

@ -0,0 +1 @@
>咘<><E59298><EFBFBD>.凃<><E58783><EFBFBD>

4
test-suite/standalone/sassy/tests/brt.scm Normal file
View file

@ -0,0 +1,4 @@
(
(brt (jnz 0))
(brnt (jae 0))
)

BIN
test-suite/standalone/sassy/tests/bt Normal file
View file

Binary file not shown.

11
test-suite/standalone/sassy/tests/bt.asm Normal file
View file

@ -0,0 +1,11 @@
BITS 32
section .text
foo:
bt si, si
btc [dword 300+edx], si
btr [8*eax], edi
bts edi, edi
bt si, 9
btc word [dword 300+edx], byte 9
btr edi, 9
bts dword [8*eax], byte 9

10
test-suite/standalone/sassy/tests/bt.scm Normal file
View file

@ -0,0 +1,10 @@
(
(bt si si)
(btc (& 100 200 edx) si)
(btr (& (* 8 eax)) edi)
(bts edi edi)
(bt si 9)
(btc (word (& 100 200 edx)) (byte 9))
(btr edi 9)
(bts (dword (& (* 8 eax))) (byte 9))
)

BIN
test-suite/standalone/sassy/tests/bt16 Normal file
View file

Binary file not shown.

11
test-suite/standalone/sassy/tests/bt16.asm Normal file
View file

@ -0,0 +1,11 @@
BITS 16
section .text
foo:
bt si, si
btc [dword 300+edx], si
btr [8*eax], edi
bts edi, edi
bt si, 9
btc word [dword 300+edx], byte 9
btr edi, 9
bts dword [8*eax], byte 9

BIN
test-suite/standalone/sassy/tests/bye Normal file
View file

Binary file not shown.

19
test-suite/standalone/sassy/tests/bye.scm Normal file
View file

@ -0,0 +1,19 @@
(export _global_offset_table_)
(import a-string)
(macro stdout 1)
(macro write (lambda (fd buffer amount)
`(begin (mov ecx ,buffer)
(mov ebx ,fd)
(mov edx ,amount)
(mov eax ,4)
(int #x80))))
(macro exit (lambda (exit-code)
`(begin (mov eax 1)
(mov ebx ,exit-code)
(int #x80))))
(entry _start)
(text (label _start get-got
(write stdout (& ebx (got a-string)) 9)
(exit 0)))

BIN
test-suite/standalone/sassy/tests/cell Executable file
View file

Binary file not shown.

15
test-suite/standalone/sassy/tests/cell.scm Normal file
View file

@ -0,0 +1,15 @@
(macro define-cell
(lambda (name init)
`(begin (macro cell-tag "CELL")
(data (label ,name (dwords cell-tag ,init)))
(macro ,(string->symbol
(string-append (symbol->string name) "-ref"))
(& ,name 4)))))
(define-cell foo 100)
(entry _start)
(text (label _start (mov ebx foo-ref)
(mov eax 1)
(int #x80)))

1
test-suite/standalone/sassy/tests/cmovcc Normal file
View file

@ -0,0 +1 @@
f@ЫfAВBаB,<2C>fBЫfCВCаC,<2C>fDЫfDВEаE,<2C>fFЫfFВGаG,<2C>fHЫfIВJаJ,<2C>fKЫfKВLаL,<2C>fMЫfMВNаN,<2C>fOЫfOВ

33
test-suite/standalone/sassy/tests/cmovcc.asm Normal file
View file

@ -0,0 +1,33 @@
BITS 32
section .text
foo:
cmovo cx, bx
cmovno bx, [edx+esi*4]
cmovb edx, eax
cmovc ebp, [esp+eax*4]
cmovnae cx, bx
cmovnb bx, [edx+esi*4]
cmovnc edx, eax
cmovae ebp, [esp+eax*4]
cmove cx, bx
cmovz bx, [edx+esi*4]
cmovne edx, eax
cmovnz ebp, [esp+eax*4]
cmovbe cx, bx
cmovna bx, [edx+esi*4]
cmova edx, eax
cmovnbe ebp, [esp+eax*4]
cmovs cx, bx
cmovns bx, [edx+esi*4]
cmovp edx, eax
cmovpe ebp, [esp+eax*4]
cmovnp cx, bx
cmovpo bx, [edx+esi*4]
cmovl edx, eax
cmovnge ebp, [esp+eax*4]
cmovge cx, bx
cmovnl bx, [edx+esi*4]
cmovle edx, eax
cmovng ebp, [esp+eax*4]
cmovnle cx, bx
cmovg bx, [edx+esi*4]

35
test-suite/standalone/sassy/tests/cmovcc.scm Normal file
View file

@ -0,0 +1,35 @@
(
(cmovo cx bx)
(cmovno bx (& edx (* esi 4)))
(cmovb edx eax)
(cmovc ebp (& esp (* eax 4)))
(cmovnae cx bx)
(cmovnb bx (& edx (* esi 4)))
(cmovnc edx eax)
(cmovae ebp (& esp (* eax 4)))
(cmove cx bx)
(cmovz bx (& edx (* esi 4)))
(cmovne edx eax)
(cmovnz ebp (& esp (* eax 4)))
(cmovbe cx bx)
(cmovna bx (& edx (* esi 4)))
(cmova edx eax)
(cmovnbe ebp (& esp (* eax 4)))
(cmovs cx bx)
(cmovns bx (& edx (* esi 4)))
(cmovp edx eax)
(cmovpe ebp (& esp (* eax 4)))
(cmovnp cx bx)
(cmovpo bx (& edx (* esi 4)))
(cmovl edx eax)
(cmovnge ebp (& esp (* eax 4)))
(cmovge cx bx)
(cmovnl bx (& edx (* esi 4)))
(cmovle edx eax)
(cmovng ebp (& esp (* eax 4)))
(cmovnle cx bx)
(cmovg bx (& edx (* esi 4)))
)

1
test-suite/standalone/sassy/tests/cmpx Normal file
View file

@ -0,0 +1 @@
°øÀ8f±ØfÁ±ØÁ

9
test-suite/standalone/sassy/tests/cmpx.asm Normal file
View file

@ -0,0 +1,9 @@
BITS 32
section .text
foo:
cmpxchg al, bh
xadd [eax], bh
cmpxchg ax, bx
xadd [eax], bx
cmpxchg eax, ebx
xadd [eax], ebx

8
test-suite/standalone/sassy/tests/cmpx.scm Normal file
View file

@ -0,0 +1,8 @@
(
(cmpxchg al bh)
(xadd (& eax) bh)
(cmpxchg ax bx)
(xadd (& eax) bx)
(cmpxchg eax ebx)
(xadd (& eax) ebx)
)

1
test-suite/standalone/sassy/tests/cmpx16 Normal file
View file

@ -0,0 +1 @@
°øgÀ8±ØgÁf±ØfgÁ

9
test-suite/standalone/sassy/tests/cmpx16.asm Normal file
View file

@ -0,0 +1,9 @@
BITS 16
section .text
foo:
cmpxchg al, bh
xadd [eax], bh
cmpxchg ax, bx
xadd [eax], bx
cmpxchg eax, ebx
xadd [eax], ebx

BIN
test-suite/standalone/sassy/tests/count Executable file
View file

Binary file not shown.

28
test-suite/standalone/sassy/tests/count.scm Normal file
View file

@ -0,0 +1,28 @@
(entry _start)
(import exit mybuff)
(export exit-code)
(data (label exit-code (bytes 0)))
(macro stdout 1)
(macro write (lambda (fd buffer amount)
`(begin (mov ebx ,fd)
(mov ecx ,buffer)
(mov edx ,amount)
(mov eax ,4)
(int #x80))))
(text
(label _start (mov ecx 0)
(mov eax "0")
(while (<= eax #\9)
(begin (push eax)
(mov (& mybuff) al)
(write stdout mybuff 1)
(pop eax)
(add eax 1)))
(jmp exit)))

BIN
test-suite/standalone/sassy/tests/decinc Normal file
View file

Binary file not shown.

9
test-suite/standalone/sassy/tests/decinc.asm Normal file
View file

@ -0,0 +1,9 @@
BITS 32
section .text
foo:
dec dword [eax]
inc word [eax]
dec byte [eax]
inc ch
dec esp
inc dx

9
test-suite/standalone/sassy/tests/decinc.scm Normal file
View file

@ -0,0 +1,9 @@
(
(dec (dword (& eax)))
(inc (word (& eax)))
(dec (byte (& eax)))
(inc ch)
(dec esp)
(inc dx)
)

BIN
test-suite/standalone/sassy/tests/decinc16 Normal file
View file

Binary file not shown.

9
test-suite/standalone/sassy/tests/decinc16.asm Normal file
View file

@ -0,0 +1,9 @@
BITS 16
section .text
foo:
dec dword [eax]
inc word [eax]
dec byte [eax]
inc ch
dec esp
inc dx

1
test-suite/standalone/sassy/tests/doub-shift Normal file
View file

@ -0,0 +1 @@
f､ﾃ fｬ ､ﾃ ｬ f･ﾃfｭ･ﾃｭ

11
test-suite/standalone/sassy/tests/doub-shift.asm Normal file
View file

@ -0,0 +1,11 @@
BITS 32
section .text
foo:
shld bx, ax, 9
shrd [ebx], ax, 9
shld ebx, eax, 9
shrd [ebx], eax, 9
shld bx, ax, cl
shrd [ebx], ax, cl
shld ebx, eax, cl
shrd [ebx], eax, cl

10
test-suite/standalone/sassy/tests/doub-shift.scm Normal file
View file

@ -0,0 +1,10 @@
(
(shld bx ax 9)
(shrd (& ebx) ax 9)
(shld ebx eax 9)
(shrd (& ebx) eax 9)
(shld bx ax cl)
(shrd (& ebx) ax cl)
(shld ebx eax cl)
(shrd (& ebx) eax cl)
)

1
test-suite/standalone/sassy/tests/doub-shift16 Normal file
View file

@ -0,0 +1 @@
､ﾃ gｬ f､ﾃ gfｬ ･ﾃgｭf･ﾃgfｭ

11
test-suite/standalone/sassy/tests/doub-shift16.asm Normal file
View file

@ -0,0 +1,11 @@
BITS 16
section .text
foo:
shld bx, ax, 9
shrd [ebx], ax, 9
shld ebx, eax, 9
shrd [ebx], eax, 9
shld bx, ax, cl
shrd [ebx], ax, cl
shld ebx, eax, cl
shrd [ebx], eax, cl

18
test-suite/standalone/sassy/tests/eip.scm Normal file
View file

@ -0,0 +1,18 @@
*(call rel32)
*(call rel16)
*(call i16 i16
*(call i16 i32
*(call 'far m16
*(call 'far m32
(call r16)
*(call m16)
(call r32)
*(call m32)
jmp
jcc
loop
jcxz/jecxz

BIN
test-suite/standalone/sassy/tests/fac5 Executable file
View file

Binary file not shown.

12
test-suite/standalone/sassy/tests/fac5.scm Normal file
View file

@ -0,0 +1,12 @@
(export _start)
(text
(label _start
(mov eax 1)
(mov ecx 5)
(while (> ecx 0)
(begin (mul ecx)
(sub ecx 1))))
(mov ebx eax)
(mov eax 1)
(int #x80))

1
test-suite/standalone/sassy/tests/fp0 Normal file
View file

@ -0,0 +1 @@
<EFBFBD>ט<EFBFBD>י<EFBFBD>ך<EFBFBD>כ<EFBFBD>ל<EFBFBD>ם<EFBFBD>מ<EFBFBD>‏<EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>ע<EFBFBD>ף<EFBFBD>נ<EFBFBD>ס<EFBFBD>ש<EFBFBD>ק<EFBFBD>צ›<EFBFBD>ד<EFBFBD>ד›<EFBFBD>ג<EFBFBD>ג››<EFBFBD>׀<EFBFBD><EFBFBD><EFBFBD>י<EFBFBD>ה<EFBFBD>ו<EFBFBD>ר<EFBFBD>ץ<EFBFBD>ב<EFBFBD>א<EFBFBD><EFBFBD><EFBFBD>‎<EFBFBD>ת<EFBFBD>פ

39
test-suite/standalone/sassy/tests/fp0.asm Normal file
View file

@ -0,0 +1,39 @@
BITS 32
section .text
foo:
fld1
fldl2t
fldl2e
fldpi
fldlg2
fldln2
fldz
fsin
fcos
fsincos
fptan
fpatan
f2xm1
fyl2x
fyl2xp1
fincstp
fdecstp
finit
fninit
fclex
fnclex
fwait
wait
fnop
fcompp
fucompp
ftst
fxam
fprem
fprem1
fabs
fchs
frndint
fscale
fsqrt
fxtract

39
test-suite/standalone/sassy/tests/fp0.scm Normal file
View file

@ -0,0 +1,39 @@
(
(fld1)
(fldl2t)
(fldl2e)
(fldpi)
(fldlg2)
(fldln2)
(fldz)
(fsin)
(fcos)
(fsincos)
(fptan)
(fpatan)
(f2xm1)
(fyl2x)
(fyl2xp1)
(fincstp)
(fdecstp)
(finit)
(fninit)
(fclex)
(fnclex)
(fwait)
(wait)
(fnop)
(fcompp)
(fucompp)
(ftst)
(fxam)
(fprem)
(fprem1)
(fabs)
(fchs)
(frndint)
(fscale)
(fsqrt)
(fxtract)
)

BIN
test-suite/standalone/sassy/tests/fp1 Normal file
View file

Binary file not shown.

21
test-suite/standalone/sassy/tests/fp1.asm Normal file
View file

@ -0,0 +1,21 @@
BITS 32
section .text
foo:
fadd dword [eax]
fsub qword [ebx]
fsubr st0, st4
fmul st7, st0
fdiv dword [eax]
fdivr qword [ebx]
fdivrp st2, st0
fdivp st2, st0
fmulp st2, st0
fsubp st3, st0
fsubrp st2, st0
faddp st4, st0
fimul dword [eax]
fiadd word [ebx]
fidiv word [ebx]
fidivr dword [eax]
fisub word [ebx]
fisubr dword [eax]

20
test-suite/standalone/sassy/tests/fp1.scm Normal file
View file

@ -0,0 +1,20 @@
(
(fadd (dword (& eax)))
(fsub (qword (& ebx)))
(fsubr st0 st4)
(fmul st7 st0)
(fdiv (dword (& eax)))
(fdivr (qword (& ebx)))
(fdivrp st2 st0)
(fdivp st2 st0)
(fmulp st2 st0)
(fsubp st3 st0)
(fsubrp st2 st0)
(faddp st4 st0)
(fimul (dword (& eax)))
(fiadd (word (& ebx)))
(fidiv (word (& ebx)))
(fidivr (dword (& eax)))
(fisub (word (& ebx)))
(fisubr (dword (& eax)))
)

1
test-suite/standalone/sassy/tests/fp2 Normal file
View file

@ -0,0 +1 @@
<EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>ד<EFBFBD>(<28><1B><01><><EFBFBD><12><13><>‗<03>‗+‗<11><11><19><1F><17><><EFBFBD>ק‗צ<E28097>ם‗ל

33
test-suite/standalone/sassy/tests/fp2.asm Normal file
View file

@ -0,0 +1,33 @@
BITS 32
section .text
foo:
fcmovb st0, st2
fcmove st0, st3
fcmovbe st0, st4
fcmovu st0, st5
fcmovnb st0, st6
fcmovne st0, st7
fcmovnbe st0, st1
fcmovnu st0, st2
fxch
fucom st3
fld tword [eax]
fstp qword [ebx]
fld dword [ecx]
fstp st4
fst dword [edx]
fst qword [ebx]
fst st3
fild word [ebx]
fistp dword [ebx]
fild qword [ebx]
fist word [ecx]
ficom dword [ecx]
ficomp word [ecx]
fcomp dword [edi]
fcom qword [edi]
fcomp st0
fcomi st0, st7
fcomip st0, st6
fucomi st0, st5
fucomip st0, st4

32
test-suite/standalone/sassy/tests/fp2.scm Normal file
View file

@ -0,0 +1,32 @@
(
(fcmovb st0 st2)
(fcmove st0 st3)
(fcmovbe st0 st4)
(fcmovu st0 st5)
(fcmovnb st0 st6)
(fcmovne st0 st7)
(fcmovnbe st0 st1)
(fcmovnu st0 st2)
(fxch)
(fucom st3)
(fld (tword (& eax)))
(fstp (qword (& ebx)))
(fld (dword (& ecx)))
(fstp st4)
(fst (dword (& edx)))
(fst (qword (& ebx)))
(fst st3)
(fild (word (& ebx)))
(fistp (dword (& ebx)))
(fild (qword (& ebx)))
(fist (word (& ecx)))
(ficom (dword (& ecx)))
(ficomp (word (& ecx)))
(fcomp (dword (& edi)))
(fcom (qword (& edi)))
(fcomp st0)
(fcomi st0 st7)
(fcomip st0 st6)
(fucomi st0 st5)
(fucomip st0 st4)
)

2
test-suite/standalone/sassy/tests/fp3 Normal file
View file

@ -0,0 +1,2 @@
п п0<D0BF>й;й+й;<3B>й0й3нТй"<22>н2н2н"ЎЎ
<EFBFBD>пр<EFBFBD>н;прн;

21
test-suite/standalone/sassy/tests/fp3.asm Normal file
View file

@ -0,0 +1,21 @@
BITS 32
section .text
foo:
fbld tword [eax]
fbstp tword [eax]
fstcw word [ebx]
fldcw word [ebx]
fnstcw word [ebx]
fstenv [eax]
fnstenv [ebx]
ffree st2
fldenv [edx]
fsave [edx]
fnsave [edx]
frstor [edx]
fxsave [edx]
fxrstor [edx]
fstsw ax
fstsw word [ebx]
fnstsw ax
fnstsw word [ebx]

20
test-suite/standalone/sassy/tests/fp3.scm Normal file
View file

@ -0,0 +1,20 @@
(
(fbld (tword (& eax)))
(fbstp (tword (& eax)))
(fstcw (word (& ebx)))
(fldcw (word (& ebx)))
(fnstcw (word (& ebx)))
(fstenv (& eax))
(fnstenv (& ebx))
(ffree st2)
(fldenv (& edx))
(fsave (& edx))
(fnsave (& edx))
(frstor (& edx))
(fxsave (& edx))
(fxrstor (& edx))
(fstsw ax)
(fstsw (word (& ebx)))
(fnstsw ax)
(fnstsw (word (& ebx)))
)

224
test-suite/standalone/sassy/tests/generate-nasm.scm Normal file
View file

@ -0,0 +1,224 @@
;loading this file populates the tests directory with .asm files and
;calls nasm to assemble them
;note: the files for seg.scm brt.scm isn't included with this
; ,open c-system-function
(define (andmap p lst)
(call-with-current-continuation
(lambda (lose)
(let iter ((lst lst))
(cond ((null? lst) '())
((p (car lst)) => (lambda (this) (cons this (iter (cdr lst)))))
(else (lose #f)))))))
(define opcode-files
(list
"tests/mem-ref.scm"
"tests/non.scm"
"tests/alu.scm"
"tests/bt.scm"
"tests/shift.scm"
"tests/setcc.scm"
"tests/cmovcc.scm"
"tests/decinc.scm"
"tests/plier.scm"
"tests/load.scm"
"tests/movx.scm"
"tests/r-rm.scm"
"tests/rm.scm"
"tests/rm2.scm"
"tests/aa.scm"
"tests/ret.scm"
"tests/doub-shift.scm"
"tests/cmpx.scm"
"tests/misc1.scm"
"tests/misc2.scm"
"tests/misc3.scm"
"tests/jcc.scm"
"tests/jumps.scm"
"tests/prefix.scm"
"tests/fp0.scm"
"tests/fp1.scm"
"tests/fp2.scm"
"tests/fp3.scm"
"tests/mmx.scm"
"tests/sse1.scm"
"tests/sse2.scm"
"tests/sse3.scm"
"tests/seg.scm"
))
(define opcode16-files
(list
"tests/alu.scm"
"tests/bt.scm"
"tests/cmpx.scm"
"tests/decinc.scm"
"tests/doub-shift.scm"
"tests/jcc.scm"
"tests/jumps.scm"
"tests/load.scm"
"tests/mem-ref.scm"
"tests/misc1.scm"
"tests/misc2.scm"
"tests/movx.scm"
"tests/non.scm"
"tests/plier.scm"
"tests/prefix.scm"
"tests/ret.scm"
"tests/rm2.scm"
"tests/rm.scm"
"tests/r-rm.scm"
"tests/setcc.scm"
"tests/shift.scm"
"tests/seg.scm"))
(define (list-fill lst filler)
(cond ((null? lst) '())
((null? (cdr lst)) lst)
(else (cons (car lst) (cons filler (list-fill (cdr lst) filler))))))
(define (sassy->nasm file lst bits)
(with-output-to-file file
(lambda ()
(letrec
((outs (lambda x (for-each display x) (newline)))
(i16 (meta-lambda
(or ,@num
,@symb
(and 'word num)
(and 'word symb))))
(i32 (meta-lambda
(or ,@num
,@symb
(and 'dword num)
(and 'dword symb))))
(prefix? (lambda (x)
(and (memq x '(rep repe repne repz repnz lock))
(symbol->string x))))
(a-sassy
(meta-lambda
(or
(and 'jmp num i32 (lambda (x y) (outs "jmp dword " x ":" y)))
(and 'jmp num i16 (lambda (x y) (outs "jmp word " x ":" y)))
(and 'call num i32 (lambda (x y) (outs "call dword " x ":" y)))
(and 'call num i16 (lambda (x y) (outs "call word " x ":" y)))
(and prefix? pair? (lambda (x y) (begin (outs x " ")
(a-sassy y))))
(and symb 'near rand (lambda (x y) (outs x " near " y)))
(and symb 'short rand (lambda (x y) (outs x " short " y)))
(and symb 'far rand (lambda (x y) (outs x " far " y)))
(and symb (lambda (x) (outs x)))
(and symb rand (lambda (x y) (outs x " " y)))
(and symb rand rand (lambda (x y z) (outs x " " y ", " z)))
(and symb rand rand rand (lambda (u v w x)
(outs u " " v ", " w ", " x))))))
(reg (lambda (x)
(and (memq x '(mm7 mm6 mm5 mm4 mm3 dr7 mm2 dr6 mm1 mm0 cr4
dr3 cr3 dr2 cr2 dr1 dr0 cr0 xmm7 xmm6
xmm5 xmm4 xmm3 xmm2 xmm1 xmm0 ss sp dx si
cx bx gs ax fs es ds cs bp dl cl bl al di
dh ch bh ah esp edx esi ecx ebx eax ebp
edi st7 st6 st5 st4 st3 st2 st1 st0))
(symbol->string x))))
(symb (lambda (x) (and (symbol? x) (not (reg x))
(symbol->string x))))
(num (lambda (x) (and (number? x) (number->string x))))
(segp (lambda (x)
(and (memq x '(cs ds ss es fs gs))
(string-append (symbol->string x) ":"))))
(skale
(meta-lambda
(or (and '* num reg (lambda (x y) (string-append x "*" y)))
(and '* reg num (lambda (x y) (string-append x "*" y))))))
(mem
(meta-lambda
(or
(and segp mem
(lambda (x y)
(if (and (> (string-length y) 7)
(string=? "[dword " (substring y 0 7)))
(string-append "[dword " x
(substring y 7 (string-length y)))
(string-append "[" x
(substring y 1 (string-length y))))))
(and '& __
(lambda x
(cond ((andmap (lambda (i) (or (num i) (symb i))) x) =>
(lambda (lst)
(apply string-append
"[dword "
(append (list-fill lst "+") (list "]")))))
(else
(let* ((nums (fold (lambda (f r)
(if (number? f)
(if (number? r)
(+ f r)
f)
r))
'()
x))
(dword (or (and (not (null? nums))
(not (u/s-byte nums)))
(any symb x)))
(itms (fold-right (lambda (x r)
(cond
((or (reg x)
(skale x) (symb x))
=> (lambda (i)
(cons i r)))
(else r)))
'()
x))
(lst (if (null? nums)
itms
(cons (number->string nums) itms))))
(if dword
(apply string-append
"[dword "
(append (list-fill lst "+")
(list "]")))
(apply string-append
"[" (append (list-fill lst "+")
(list "]")))
)))))))))
(sizer (lambda (x)
(and (memv x '(byte word dword qword tword dqword))
(symbol->string x))))
(rand
(meta-lambda
(or ,@reg
,@num
,@mem
,@symb
(and sizer (or num mem reg symb)
(lambda (x y)
(string-append x " " y)))))))
(display bits)
(newline)
(display "section .text")
(newline)
(display "foo:")
(newline)
(for-each a-sassy lst)))))
(define (gen-file x bits32?)
(let* ((nasm-asm (string-append
(substring x 0 (- (string-length x) 4))
(if bits32? ".asm" "16.asm")))
(nasm-out (string-append
(substring x 0 (- (string-length x) 4))
(if bits32? "" "16")))
(the-codes (with-input-from-file x (lambda () (read))))
(nasm-com (string-append "nasm -f bin " nasm-asm)))
(and (file-exists? nasm-asm) (delete-file nasm-asm))
(and (file-exists? nasm-out) (delete-file nasm-out))
(sassy->nasm nasm-asm the-codes (if bits32? "BITS 32" "BITS 16"))
(system nasm-com)))
; (for-each (lambda (x) (gen-file x #t)) opcode-files)
; (for-each (lambda (x) (gen-file x #f)) opcode16-files)

161
test-suite/standalone/sassy/tests/generate-prim.scm Normal file
View file

@ -0,0 +1,161 @@
;really these files should never be re-generated unless you're prepared
;to inspect everyone of them for correctness. (Since they've already been inspected by hand).
(define the-prims
(list "tests/prims/seq1.scm"
"tests/prims/seq2.scm"
"tests/prims/seq3.scm"
"tests/prims/alt1.scm"
"tests/prims/alt2.scm"
"tests/prims/alt3.scm"
"tests/prims/alt4.scm"
"tests/prims/begin1.scm"
"tests/prims/begin2.scm"
"tests/prims/begin3.scm"
"tests/prims/begin4.scm"
"tests/prims/begin5.scm"
"tests/prims/if1.scm"
"tests/prims/if2.scm"
"tests/prims/if3.scm"
"tests/prims/if4.scm"
"tests/prims/inv1.scm"
"tests/prims/inv2.scm"
"tests/prims/inv3.scm"
"tests/prims/inv4.scm"
"tests/prims/inv5.scm"
"tests/prims/inv6.scm"
"tests/prims/iter1.scm"
"tests/prims/iter2.scm"
"tests/prims/iter3.scm"
"tests/prims/iter4.scm"
"tests/prims/iter5.scm"
"tests/prims/iter6.scm"
"tests/prims/leap-mark1.scm"
"tests/prims/leap-mark2.scm"
"tests/prims/leap-mark3.scm"
"tests/prims/while1.scm"
"tests/prims/while2.scm"
"tests/prims/while3.scm"
"tests/prims/with-win1.scm"
"tests/prims/with-win2.scm"
"tests/prims/with-win3.scm"
"tests/prims/with-win4.scm"
"tests/prims/with-win5.scm"
"tests/prims/with-lose1.scm"
"tests/prims/with-lose2.scm"
"tests/prims/with-lose3.scm"
"tests/prims/with-win-lose1.scm"
"tests/prims/with-win-lose2.scm"
"tests/prims/with-win-lose3.scm"
"tests/prims/with-win-lose4.scm"
"tests/prims/with-win-lose5.scm"
"tests/prims/exp-k1.scm"
"tests/prims/exp-k2.scm"
"tests/prims/exp-k3.scm"
"tests/prims/exp-k4.scm"
"tests/prims/esc1.scm"
"tests/prims/esc2.scm"
"tests/prims/esc3.scm"
"tests/prims/esc4.scm"
"tests/prims/esc5.scm"
"tests/prims/esc6.scm"
"tests/prims/esc7.scm"
"tests/prims/label1.scm"
"tests/prims/label2.scm"
"tests/prims/label3.scm"
"tests/prims/label4.scm"
"tests/prims/locals1.scm"
"tests/prims/locals2.scm"
"tests/prims/locals3.scm"
"tests/prims/locals4.scm"
"tests/prims/locals5.scm"
"tests/prims/locals6.scm"
"tests/prims/locals7.scm"
"tests/prims/locals8.scm"
))
(define prims16
(list "tests/prims16/16seq1.scm"
"tests/prims16/16seq2.scm"
"tests/prims16/16seq3.scm"
"tests/prims16/16alt1.scm"
"tests/prims16/16alt2.scm"
"tests/prims16/16alt3.scm"
"tests/prims16/16alt4.scm"
"tests/prims16/16begin1.scm"
"tests/prims16/16begin2.scm"
"tests/prims16/16begin3.scm"
"tests/prims16/16begin4.scm"
"tests/prims16/16begin5.scm"
"tests/prims16/16if1.scm"
"tests/prims16/16if2.scm"
"tests/prims16/16if3.scm"
"tests/prims16/16if4.scm"
"tests/prims16/16inv1.scm"
"tests/prims16/16inv2.scm"
"tests/prims16/16inv3.scm"
"tests/prims16/16inv4.scm"
"tests/prims16/16inv5.scm"
"tests/prims16/16inv6.scm"
"tests/prims16/16iter1.scm"
"tests/prims16/16iter2.scm"
"tests/prims16/16iter3.scm"
"tests/prims16/16iter4.scm"
"tests/prims16/16iter5.scm"
"tests/prims16/16iter6.scm"
"tests/prims16/16leap-mark1.scm"
"tests/prims16/16leap-mark2.scm"
"tests/prims16/16leap-mark3.scm"
"tests/prims16/16while1.scm"
"tests/prims16/16while2.scm"
"tests/prims16/16while3.scm"
"tests/prims16/16with-win1.scm"
"tests/prims16/16with-win2.scm"
"tests/prims16/16with-win3.scm"
"tests/prims16/16with-win4.scm"
"tests/prims16/16with-win5.scm"
"tests/prims16/16with-lose1.scm"
"tests/prims16/16with-lose2.scm"
"tests/prims16/16with-lose3.scm"
"tests/prims16/16with-win-lose1.scm"
"tests/prims16/16with-win-lose2.scm"
"tests/prims16/16with-win-lose3.scm"
"tests/prims16/16with-win-lose4.scm"
"tests/prims16/16with-win-lose5.scm"
"tests/prims16/16exp-k1.scm"
"tests/prims16/16exp-k2.scm"
"tests/prims16/16exp-k3.scm"
"tests/prims16/16exp-k4.scm"
"tests/prims16/16esc1.scm"
"tests/prims16/16esc2.scm"
"tests/prims16/16esc3.scm"
"tests/prims16/16esc4.scm"
"tests/prims16/16esc5.scm"
"tests/prims16/16esc6.scm"
"tests/prims16/16esc7.scm"
"tests/prims16/16label1.scm"
"tests/prims16/16label2.scm"
"tests/prims16/16label3.scm"
"tests/prims16/16label4.scm"
"tests/prims16/16locals1.scm"
"tests/prims16/16locals2.scm"
"tests/prims16/16locals3.scm"
"tests/prims16/16locals4.scm"
"tests/prims16/16locals5.scm"
"tests/prims16/16locals6.scm"
"tests/prims16/16locals7.scm"
"tests/prims16/16locals8.scm"
))
(define (go-gen lst)
(for-each
(lambda (x)
(let ((outp (substring x 0 (- (string-length x) 4))))
(and (file-exists? outp)
(delete-file outp))
(sassy-make-bin outp (sassy x))))
lst))
; (go-gen the-prims)
; (go-gen prims16)

BIN
test-suite/standalone/sassy/tests/hello Normal file
View file

Binary file not shown.

9
test-suite/standalone/sassy/tests/hello.scm Normal file
View file

@ -0,0 +1,9 @@
(export _global_offset_table_)
(import say-hello)
(entry _start)
(text (label _start (jmp (plt say-hello))))

2
test-suite/standalone/sassy/tests/include.scm Normal file
View file

@ -0,0 +1,2 @@
(text (align 32)
(label foo (push eax)))

1
test-suite/standalone/sassy/tests/jcc Normal file
View file

@ -0,0 +1 @@
€ϊ<E282AC><CF8A><EFBFBD>f<0F>υ<EFBFBD>‚ο<E2809A><CEBF><EFBFBD>‚ι<E2809A><CEB9><EFBFBD>f‚δ<E2809A>ƒή<C692><CEAE><EFBFBD>ƒΨ<C692><CEA8><EFBFBD>fƒΣ<C692>„Ν<E2809E><CE9D><EFBFBD>„Η<E2809E><CE97><EFBFBD>f…Β<E280A6>…Ό<E280A6><CE8C><EFBFBD>†¶<E280A0><C2B6><EFBFBD>f†±<E280A0>‡«<E280A1><C2AB><EFBFBD>‡¥<E280A1><C2A5><EFBFBD>f<0F> <EFBFBD>‰<><E280B0><EFBFBD><EFBFBD><0F>”<EFBFBD><E2809D><EFBFBD>f<0F><><EFBFBD>‹‰<E280B9><E280B0><EFBFBD>‹ƒ<E280B9><C692><EFBFBD>f<0F>~<7E><0F>x<EFBFBD><78><EFBFBD><0F>r<EFBFBD><72><EFBFBD>f<0F>m<EFBFBD><0F>g<EFBFBD><67><EFBFBD><0F>a<EFBFBD><61><EFBFBD>f<0F>\<5C><0F>V<EFBFBD><56><EFBFBD>

33
test-suite/standalone/sassy/tests/jcc.asm Normal file
View file

@ -0,0 +1,33 @@
BITS 32
section .text
foo:
jo near dword foo
jno near word foo
jb 0
jc near dword foo
jnae near word foo
jnb 0
jnc near dword foo
jae near word foo
je 0
jz near dword foo
jne near word foo
jnz 0
jbe near dword foo
jna near word foo
ja 0
jnbe near dword foo
js near word foo
jns 0
jp near dword foo
jpe near word foo
jnp 0
jpo near dword foo
jl near word foo
jnge 0
jge near dword foo
jnl near word foo
jle 0
jng near dword foo
jnle near word foo
jg 0

32
test-suite/standalone/sassy/tests/jcc.scm Normal file
View file

@ -0,0 +1,32 @@
(
(jo near (dword foo))
(jno near (word foo))
(jb 0)
(jc near (dword foo))
(jnae near (word foo))
(jnb 0)
(jnc near (dword foo))
(jae near (word foo))
(je 0)
(jz near (dword foo))
(jne near (word foo))
(jnz 0)
(jbe near (dword foo))
(jna near (word foo))
(ja 0)
(jnbe near (dword foo))
(js near (word foo))
(jns 0)
(jp near (dword foo))
(jpe near (word foo))
(jnp 0)
(jpo near (dword foo))
(jl near (word foo))
(jnge 0)
(jge near (dword foo))
(jnl near (word foo))
(jle 0)
(jng near (dword foo))
(jnle near (word foo))
(jg 0)
)

1
test-suite/standalone/sassy/tests/jcc16 Normal file
View file

@ -0,0 +1 @@
f€<><E282AC><EFBFBD><EFBFBD>侕<>傫<>f傟<><E5829F><EFBFBD>傛<>冣<>f冔<><E58694><EFBFBD>冏<>動<>f勌<><E58B8C><EFBFBD>吶<>吥<>f喗<><E59697><EFBFBD>喒<>嚨<>f嚠<><E59AA0><EFBFBD>埅<>墻<>f姛<><E5A79B><EFBFBD>姏<>嫍<>f嫄<><E5AB84><EFBFBD>寣<>寛<>f崄<><E5B484><EFBFBD>峿<>巠<>f巖<><E5B796><EFBFBD>弉<>廽<>

33
test-suite/standalone/sassy/tests/jcc16.asm Normal file
View file

@ -0,0 +1,33 @@
BITS 16
section .text
foo:
jo near dword foo
jno near word foo
jb 0
jc near dword foo
jnae near word foo
jnb 0
jnc near dword foo
jae near word foo
je 0
jz near dword foo
jne near word foo
jnz 0
jbe near dword foo
jna near word foo
ja 0
jnbe near dword foo
js near word foo
jns 0
jp near dword foo
jpe near word foo
jnp 0
jpo near dword foo
jl near word foo
jnge 0
jge near dword foo
jnl near word foo
jle 0
jng near dword foo
jnle near word foo
jg 0

BIN
test-suite/standalone/sassy/tests/jumps Normal file
View file

Binary file not shown.

36
test-suite/standalone/sassy/tests/jumps.asm Normal file
View file

@ -0,0 +1,36 @@
BITS 32
section .text
foo:
loop foo
loope foo, cx
loopz foo, ecx
loopne foo
loopnz foo, cx
jcxz foo
jecxz foo
call dword 0
call word 0
call dword 1000:1000
call word 1000:1000
call dword 1000:1000
call word 1000:1000
call far dword [ecx]
call far word [ecx]
call ecx
call dword [ecx]
call cx
call word [ecx]
jmp dword 0
jmp near dword 0
jmp word 0
jmp near word 0
jmp dword 1000:1000
jmp word 1000:1000
jmp dword 1000:foo
jmp word 1000:foo
jmp far dword [ecx]
jmp far word [ecx]
jmp ecx
jmp dword [ecx]
jmp cx
jmp word [ecx]

35
test-suite/standalone/sassy/tests/jumps.scm Normal file
View file

@ -0,0 +1,35 @@
(
(loop foo)
(loope foo cx)
(loopz foo ecx)
(loopne foo)
(loopnz foo cx)
(jcxz foo)
(jecxz foo)
(call (dword 0))
(call (word 0))
(call 1000 (dword 1000))
(call 1000 (word 1000))
(call 1000 (dword 1000))
(call 1000 (word 1000))
(call far (dword (& ecx)))
(call far (word (& ecx)))
(call ecx)
(call (dword (& ecx)))
(call cx)
(call (word (& ecx)))
(jmp (dword 0))
(jmp near (dword 0))
(jmp (word 0))
(jmp near (word 0))
(jmp 1000 (dword 1000))
(jmp 1000 (word 1000))
(jmp 1000 (dword foo))
(jmp 1000 (word foo))
(jmp far (dword (& ecx)))
(jmp far (word (& ecx)))
(jmp ecx)
(jmp (dword (& ecx)))
(jmp cx)
(jmp (word (& ecx)))
)

BIN
test-suite/standalone/sassy/tests/jumps16 Normal file
View file

Binary file not shown.

36
test-suite/standalone/sassy/tests/jumps16.asm Normal file
View file

@ -0,0 +1,36 @@
BITS 16
section .text
foo:
loop foo
loope foo, cx
loopz foo, ecx
loopne foo
loopnz foo, cx
jcxz foo
jecxz foo
call dword 0
call word 0
call dword 1000:1000
call word 1000:1000
call dword 1000:1000
call word 1000:1000
call far dword [ecx]
call far word [ecx]
call ecx
call dword [ecx]
call cx
call word [ecx]
jmp dword 0
jmp near dword 0
jmp word 0
jmp near word 0
jmp dword 1000:1000
jmp word 1000:1000
jmp dword 1000:foo
jmp word 1000:foo
jmp far dword [ecx]
jmp far word [ecx]
jmp ecx
jmp dword [ecx]
jmp cx
jmp word [ecx]

6
test-suite/standalone/sassy/tests/libgoodbye.scm Normal file
View file

@ -0,0 +1,6 @@
(export _global_offset_table_)
(data (label a-string (bytes "Goodbye." #\newline)))
(export a-string)

BIN
test-suite/standalone/sassy/tests/libgoodbye.so Normal file
View file

Binary file not shown.

30
test-suite/standalone/sassy/tests/libhello.scm Normal file
View file

@ -0,0 +1,30 @@
(export _global_offset_table_ say-hello the-string1)
(import a-string)
(data (label the-string1 (bytes "Hello "))
(label the-string2 (bytes "World." #\newline))
(label boxed-one (dwords (sym the-string1))))
(macro stdout 1)
(macro write (lambda (fd buffer amount)
`(begin (mov ecx ,buffer)
(mov ebx ,fd)
(mov edx ,amount)
(mov eax ,4)
(int #x80))))
(text
(label exit (mov eax 1)
(mov ebx 0)
(int #x80))
(label say-hello get-got
(push ebx)
(lea eax (& ebx (got-offset boxed-one)))
(write stdout (& eax) 6)
(mov ebx (& esp))
(lea eax (& ebx (got-offset the-string2)))
(write stdout eax 7)
(mov ebx (& esp))
(write stdout (& ebx (got a-string)) 9)
(jmp exit)))

BIN
test-suite/standalone/sassy/tests/libhello.so Normal file
View file

Binary file not shown.

BIN
test-suite/standalone/sassy/tests/liblocaldata3.so Executable file
View file

Binary file not shown.

1
test-suite/standalone/sassy/tests/load Normal file
View file

@ -0,0 +1 @@
Å>fÄ><3E>>f´>µ>f²>

9
test-suite/standalone/sassy/tests/load.asm Normal file
View file

@ -0,0 +1,9 @@
BITS 32
section .text
foo:
lds edi, [esi]
les di, [esi]
lea edi, [esi]
lfs di, [esi]
lgs edi, [esi]
lss di, [esi]

9
test-suite/standalone/sassy/tests/load.scm Normal file
View file

@ -0,0 +1,9 @@
(
(lds edi (& esi))
(les di (& esi))
(lea edi (& esi))
(lfs di (& esi))
(lgs edi (& esi))
(lss di (& esi))
)

1
test-suite/standalone/sassy/tests/load16 Normal file
View file

@ -0,0 +1 @@
fgХ>gФ>fg<66>>gД>fgЕ>gВ>

9
test-suite/standalone/sassy/tests/load16.asm Normal file
View file

@ -0,0 +1,9 @@
BITS 16
section .text
foo:
lds edi, [esi]
les di, [esi]
lea edi, [esi]
lfs di, [esi]
lgs edi, [esi]
lss di, [esi]

BIN
test-suite/standalone/sassy/tests/local-data-static Executable file
View file

Binary file not shown.

Some files were not shown because too many files have changed in this diff Show more