summaryrefslogtreecommitdiff
path: root/pit/test
diff options
context:
space:
mode:
authorLLLL Colonq <llll@colonq>2026-10-23 20:47:43 -0400
committerLLLL Colonq <llll@colonq>2026-10-23 20:48:45 -0400
commitdb58f43065c3b397754bb9efcb4a7376b2538131 (patch)
tree81452d262163237e82821e0eb5e518e581fa9276 /pit/test
parent62ab8e0b42a57bd794941f030b4c3140d6f7c744 (diff)
pit: Add tests, fix binding bugHEADmaster
Diffstat (limited to 'pit/test')
-rw-r--r--pit/test/6502.pit174
-rw-r--r--pit/test/array.pit2
-rw-r--r--pit/test/backtrace.pit2
-rw-r--r--pit/test/bif.pit12
-rw-r--r--pit/test/broken.pit5
-rw-r--r--pit/test/compile.pit6
-rw-r--r--pit/test/core.pit1
-rw-r--r--pit/test/error.pit1
-rw-r--r--pit/test/error2.pit4
-rw-r--r--pit/test/fold.pit12
-rw-r--r--pit/test/gc.pit13
-rw-r--r--pit/test/horriblebindingbug.pit6
-rw-r--r--pit/test/int.pit1
-rw-r--r--pit/test/loadpath.pit2
-rw-r--r--pit/test/nonbroken.pit2
-rw-r--r--pit/test/recurse.pit5
-rw-r--r--pit/test/struct.pit11
-rw-r--r--pit/test/test.pit22
-rw-r--r--pit/test/test10.pit5
-rw-r--r--pit/test/test11.pit4
-rw-r--r--pit/test/test2.pit1
-rw-r--r--pit/test/test3.pit7
-rw-r--r--pit/test/test4.pit6
-rw-r--r--pit/test/test5.pit6
-rw-r--r--pit/test/test6.pit6
-rw-r--r--pit/test/test7.pit1
-rw-r--r--pit/test/test8.pit2
-rw-r--r--pit/test/test9.pit2
-rw-r--r--pit/test/thebug.pit9
-rw-r--r--pit/test/thebug2.pit13
-rw-r--r--pit/test/x86.pit451
-rw-r--r--pit/test/y.pit5
32 files changed, 7 insertions, 792 deletions
diff --git a/pit/test/6502.pit b/pit/test/6502.pit
deleted file mode 100644
index eb5a4e8..0000000
--- a/pit/test/6502.pit
+++ /dev/null
@@ -1,174 +0,0 @@
-;; (implicit )
-;; (accumulator )
-;; (immediate )
-;; (zeropage )
-;; (zeropage-x )
-;; (zeropage-y )
-;; (relative )
-;; (absolute )
-;; (absolute-x )
-;; (absolute-y )
-;; (indirect )
-;; (indexed-indirect )
-;; (indirect-indexed )
-
-(defun! 6502/ensure-u8 (x)
- (if (and (>= x 0) (<= x 0xff))
- (list x)
- (error! "operand out of range")))
-
-(defun! 6502/ensure-i8 (x)
- (cond
- ((and (>= x 0) (<= x 127)) (list x))
- ((and (>= x -128) (< x 0)) (list (+ 0xff x)))
- (error! "operand out of range")))
-
-(defun! 6502/ensure-u16 (x)
- (if (and (>= (car x) 0) (<= (car x) 0xffff))
- (list (bitwise/and 0xff x) (bitwise/and 0xff (bitwise/rshift x 8)))
- (error! "operand out of range")))
-
-(defun! 6502/identify-operand (x)
- (cond
- ((equal? x nil) (cons 'implicit nil)) ;; (<op> )
- ((equal? x '(a)) (cons 'accumulator nil)) ;; (<op> a)
- ((integer? (car x)) (cons 'immediate (6502/ensure-u8 (car x)))) ;; (<op> 0x0f)
- ((equal? (caar x) 'zeropage) ;; (<op> (zeropage 0x0f x))
- (let ((zp (car x)))
- (let ((a (6502/ensure-u8 (cadr zp))))
- (case (caddr zp)
- (x (cons 'zeropage-x a))
- (y (cons 'zeropage-y a))
- (nil (cons 'zeropage a))
- (t (error! "unknown zeropage offset register"))))))
- ((equal? (caar x) 'relative) ;; (<op> (relative 0x0f))
- (cons 'relative (6502/ensure-i8 (cadar x))))
- ((equal? (caar x) 'absolute) ;; (<op> (absolute 0x0f x))
- (let ((ab (car x)))
- (let ((a (6502/ensure-u16 (cadr ab))))
- (case (caddr ab)
- (x (cons 'absolute-x a))
- (y (cons 'absolute-y a))
- (nil (cons 'absolute a))
- (t (error! "unknown absolute offset register"))))))
- ((equal? (caar x) 'indirect)
- (cons 'indirect (6502/ensure-u16 (cadar x))))
- ((and (equal? (caar x) 'indexed-indirect) (equal? (caddar x) 'x))
- (cons 'indexed-indirect (6502/ensure-u16 (cadar x))))
- ((and (equal? (caar x) 'indirect-indexed) (equal? (caddar x) 'y))
- (cons 'indexed-indirect (6502/ensure-u16 (cadar y))))
- (t (error! "unknown operand"))))
-
-(defun! 6502/single (op)
- (case op
- ;; conditional branches
- (bpl 0x10)
- (bmi 0x30)
- (bvc 0x50)
- (bvs 0x70)
- (bcc 0x90)
- (bcs 0xb0)
- (bne 0xd0)
- (beq 0xf0)
- ;; other instructions
- (brk 0x00)
- (jsr 0x20)
- (rti 0x40)
- (rts 0x60)
- ;; other single-byte instructions
- (php 0x08)
- (clc 0x18)
- (plp 0x28)
- (sec 0x38)
- (pha 0x48)
- (cli 0x58)
- (pla 0x68)
- (sei 0x78)
- (dey 0x88)
- (tya 0x98)
- (tay 0xa8)
- (clv 0xb8)
- (iny 0xc8)
- (cld 0xd8)
- (inx 0xe8)
- (sed 0xf8)
- (txa 0x8a)
- (txs 0x9a)
- (tax 0xaa)
- (tsx 0xba)
- (dex 0xca)
- (nop 0xea)
- (t (error! "invalid single-byte instruction"))))
-
-(defun! 6502/grouped (group opbits amodebits)
- (bitwise/or
- (bitwise/lshift (bitwise/and 0b111 opbits) 5)
- (bitwise/lshift (bitwise/and 0b111 amodebits) 2)
- group))
-
-(defun! 6502/group1 (op amode)
- (6502/grouped 0b01
- (case op
- (ora 0b000)
- (and 0b001)
- (eor 0b010)
- (adc 0b011)
- (sta 0b100)
- (lda 0b101)
- (cmp 0b110)
- (sbc 0b111)
- (t (error! "invalid group 1 opcode")))
- (case amode
- (indexed-indirect 0b000)
- (zeropage 0b001)
- (immediate 0b010)
- (absolute 0b011)
- (indirect-indexed 0b100)
- (zeropage-x 0b101)
- (absolute-y 0b110)
- (absolute-x 0b111)
- (t (error! "invalid addressing mode for group 1")))))
-
-(defun! 6502/group2 (op amode)
- (6502/grouped 0b10
- (case op
- (asl 0b000)
- (rol 0b001)
- (lsr 0b010)
- (ror 0b011)
- (stx 0b100)
- (ldx 0b101)
- (dec 0b110)
- (inc 0b111)
- (t (error! "invalid group 2 opcode")))
- (cond
- ((and (or (equal? op 'stx) (equal? op 'ldx)) (equal? amode 'zeropage-y)) 0b101)
- ((and (equal? op 'ldx) (equal? amode 'absolute-y)) 0b111)
- (t
- (case amode
- (immediate 0b000)
- (zeropage 0b001)
- (accumulator 0b010)
- (absolute 0b011)
- (zeropage-x 0b101)
- (absolute-x 0b111)
- (t (error! "invalid addressing mode for group 2")))))))
-
-(defun! 6502/group3 (op amode)
- (6502/grouped 0b00
- (case op
- (bit 0b001)
- (jmp 0b010)
- (jmp-abs 0b011)
- (sty 0b100)
- (ldy 0b101)
- (cpy 0b110)
- (cpx 0b111)
- (t (error! "invalid group 3 opcode")))
- (case amode
- (immediate 0b000)
- (zeropage 0b001)
- (absolute 0b011)
- (zeropage-x 0b101)
- (absolute-x 0b111)
- (t (error! "invalid addressing mode for group 3")))))
diff --git a/pit/test/array.pit b/pit/test/array.pit
deleted file mode 100644
index 976f70d..0000000
--- a/pit/test/array.pit
+++ /dev/null
@@ -1,2 +0,0 @@
-(print! (array/repeat 'foo 1000))
-(array/repeat 'foo 10000)
diff --git a/pit/test/backtrace.pit b/pit/test/backtrace.pit
deleted file mode 100644
index 8a44951..0000000
--- a/pit/test/backtrace.pit
+++ /dev/null
@@ -1,2 +0,0 @@
-(defun! foo (x) (* x 2))
-(foo "bar") \ No newline at end of file
diff --git a/pit/test/bif.pit b/pit/test/bif.pit
deleted file mode 100644
index 81a1248..0000000
--- a/pit/test/bif.pit
+++ /dev/null
@@ -1,12 +0,0 @@
-(print! nil)
-(print! nil)
-(print! t)
-(print! (eq? 1 1))
-(diagnostics!)
-(defun! bif (x)
- (cons x x))
-(diagnostics!)
-(setq! foo (print! (bif (bif (bif 67)))))
-(print! (eq? (car foo) (cdr foo)))
-(diagnostics!)
-(print! foo)
diff --git a/pit/test/broken.pit b/pit/test/broken.pit
deleted file mode 100644
index 09f4afc..0000000
--- a/pit/test/broken.pit
+++ /dev/null
@@ -1,5 +0,0 @@
-;; (let ((foo (+ 1 1)))
-;; (print! foo))
-((lambda (foo)
- (print! foo))
- (+ 1 1))
diff --git a/pit/test/compile.pit b/pit/test/compile.pit
deleted file mode 100644
index 37d7f57..0000000
--- a/pit/test/compile.pit
+++ /dev/null
@@ -1,6 +0,0 @@
-(defmacro! foo ()
- (setq! bar (lambda (x) (foo) (+ x 1)))
- '(print 'hi))
-
-(foo)
-(print (funcall bar 1)) \ No newline at end of file
diff --git a/pit/test/core.pit b/pit/test/core.pit
new file mode 100644
index 0000000..51e28a7
--- /dev/null
+++ b/pit/test/core.pit
@@ -0,0 +1 @@
+(assert! 'cons '(1 . 2) (cons 1 2))
diff --git a/pit/test/error.pit b/pit/test/error.pit
deleted file mode 100644
index 58b7d99..0000000
--- a/pit/test/error.pit
+++ /dev/null
@@ -1 +0,0 @@
-(print! "hello")
diff --git a/pit/test/error2.pit b/pit/test/error2.pit
deleted file mode 100644
index 63ab173..0000000
--- a/pit/test/error2.pit
+++ /dev/null
@@ -1,4 +0,0 @@
-(defun! foo ()
- (error! "yuck"))
-
-(foo)
diff --git a/pit/test/fold.pit b/pit/test/fold.pit
deleted file mode 100644
index 89031d0..0000000
--- a/pit/test/fold.pit
+++ /dev/null
@@ -1,12 +0,0 @@
-(defun! foo (x)
- (+ x 1))
-(print! (foo 1))
-(print! (funcall 'foo 1))
-(print! (list/map 'foo '(1 2 3)))
-(print! (list/foldl '+ 0 '(1 2 3)))
-(print! (list/take 2 '(1 2 3)))
-(print! (list/take 0 '(1 2 3)))
-(print! (list/take 100 '(1 2 3)))
-(print! (list/drop 2 '(1 2 3)))
-(print! (list/drop 10 '(1 2 3)))
-(print! (list/filter 'integer? '(1 foo 2 bar baz 3 quux)))
diff --git a/pit/test/gc.pit b/pit/test/gc.pit
deleted file mode 100644
index 28eed50..0000000
--- a/pit/test/gc.pit
+++ /dev/null
@@ -1,13 +0,0 @@
-(diagnostics!)
-(setq! foo (cons 1 2))
-(setq! bar (cons foo 3))
-(setq! baz (cons bar foo))
-(diagnostics!)
-(print! foo)
-(setcar! foo baz)
-(print! (cdr (car (car foo))))
-(diagnostics!)
-(setq! foo nil)
-(setq! bar nil)
-(setq! baz nil)
-(diagnostics!)
diff --git a/pit/test/horriblebindingbug.pit b/pit/test/horriblebindingbug.pit
new file mode 100644
index 0000000..7f48b69
--- /dev/null
+++ b/pit/test/horriblebindingbug.pit
@@ -0,0 +1,6 @@
+(defun! broken (ops) nil)
+(defun! test (ops)
+ (let ((oldops ops))
+ (broken 'foo)
+ (assert! 'horriblebindingbug oldops ops)))
+(test '(1 2 3))
diff --git a/pit/test/int.pit b/pit/test/int.pit
deleted file mode 100644
index 65646af..0000000
--- a/pit/test/int.pit
+++ /dev/null
@@ -1 +0,0 @@
-(print! 0x10)
diff --git a/pit/test/loadpath.pit b/pit/test/loadpath.pit
deleted file mode 100644
index 5f8bcf8..0000000
--- a/pit/test/loadpath.pit
+++ /dev/null
@@ -1,2 +0,0 @@
-;; (setq! *load-path* (list "test/"))
-(load! "test.pit") \ No newline at end of file
diff --git a/pit/test/nonbroken.pit b/pit/test/nonbroken.pit
deleted file mode 100644
index 350f64f..0000000
--- a/pit/test/nonbroken.pit
+++ /dev/null
@@ -1,2 +0,0 @@
-(+ 1
- (fwefwfwfwe 1 1))
diff --git a/pit/test/recurse.pit b/pit/test/recurse.pit
deleted file mode 100644
index 8e1f784..0000000
--- a/pit/test/recurse.pit
+++ /dev/null
@@ -1,5 +0,0 @@
-(defun! foo ()
- (print! 'hi)
- (foo))
-
-(foo) \ No newline at end of file
diff --git a/pit/test/struct.pit b/pit/test/struct.pit
deleted file mode 100644
index 9e35654..0000000
--- a/pit/test/struct.pit
+++ /dev/null
@@ -1,11 +0,0 @@
-(defstruct! foo
- x
- y
- z)
-
-(setq! x (foo/new :y 10 :x 5 :z 111))
-(print! x)
-(print! (foo/get-y x))
-(foo/set-y! x 42)
-(print! (foo/get-y x))
-(print! (foo/get-z x))
diff --git a/pit/test/test.pit b/pit/test/test.pit
deleted file mode 100644
index ef13abb..0000000
--- a/pit/test/test.pit
+++ /dev/null
@@ -1,22 +0,0 @@
-(print! (list/map (lambda (x) (+ x 1)) (list 1 2 3 4 5)))
-(print! (eval! '(cons 1 2)))
-(defun! say-hi ()
- (princ! "hello computer"))
-(say-hi)
-(setq! counter 42)
-(let ((counter 0))
- (print! counter)
- (fset! 'count (lambda () (setq! counter (+ counter 1))))
- (fset! 'query (lambda () counter)))
-(print! (count)) (print! (query))
-(print! (count)) (print! (query))
-(defun! bar (x & xs)
- (print! x)
- (print! xs))
-(bar 1 2 3 4 5)
-(defun! baz (& kwargs)
- (print! kwargs)
- (let ((foo (plist/get :foo kwargs))
- (bar (plist/get :bar kwargs)))
- bar))
-(print! (baz :foo 10 :bar 5 :baz 3))
diff --git a/pit/test/test10.pit b/pit/test/test10.pit
deleted file mode 100644
index 0eea605..0000000
--- a/pit/test/test10.pit
+++ /dev/null
@@ -1,5 +0,0 @@
-(list/find
- (lambda (y)
- (and (eq? (list/len y) 3)
- (list/all? (lambda (x) (equal? x 2)) y)))
- '((1 2 3) (2 2 2 2) (2 3 4) (2 2 2))) \ No newline at end of file
diff --git a/pit/test/test11.pit b/pit/test/test11.pit
deleted file mode 100644
index 83d4816..0000000
--- a/pit/test/test11.pit
+++ /dev/null
@@ -1,4 +0,0 @@
-(print! 'here)
-(list/foldl '+ 0 '(1 2 3))
-(print! 'there)
-(print! (list/foldl '+ 0 '(1 2 3))) \ No newline at end of file
diff --git a/pit/test/test2.pit b/pit/test/test2.pit
deleted file mode 100644
index a86f8d2..0000000
--- a/pit/test/test2.pit
+++ /dev/null
@@ -1 +0,0 @@
-(print! "hello from test2")
diff --git a/pit/test/test3.pit b/pit/test/test3.pit
deleted file mode 100644
index 1964242..0000000
--- a/pit/test/test3.pit
+++ /dev/null
@@ -1,7 +0,0 @@
-(let ((bs (bs/new!)))
- (print! bs)
- ;; (bs/grow! 1 bs)
- (bs/write8! bs 0 67)
- (bs/spit! "test3.bin" bs)
- ;; (bs/delete! bs)
- )
diff --git a/pit/test/test4.pit b/pit/test/test4.pit
deleted file mode 100644
index ef8e04c..0000000
--- a/pit/test/test4.pit
+++ /dev/null
@@ -1,6 +0,0 @@
-(print!
- (or
- (case 'baz
- (foo 1)
- (bar 2))
- 3)) \ No newline at end of file
diff --git a/pit/test/test5.pit b/pit/test/test5.pit
deleted file mode 100644
index 2ad3675..0000000
--- a/pit/test/test5.pit
+++ /dev/null
@@ -1,6 +0,0 @@
-(defun! foo (x)
- (if (equal? 0 (% x 10000))
- (print! x))
- (foo (+ x 1)))
-
-(foo 0) \ No newline at end of file
diff --git a/pit/test/test6.pit b/pit/test/test6.pit
deleted file mode 100644
index cb04f22..0000000
--- a/pit/test/test6.pit
+++ /dev/null
@@ -1,6 +0,0 @@
-(print!
- ((case 'baz
- (foo (lambda (x) (+ x 1)))
- (bar (lambda (x) (+ x 2))))
- 3))
- \ No newline at end of file
diff --git a/pit/test/test7.pit b/pit/test/test7.pit
deleted file mode 100644
index 48d2c2c..0000000
--- a/pit/test/test7.pit
+++ /dev/null
@@ -1 +0,0 @@
-(print! (list/map (lambda (x) (+ x 1)) '(1 2 3))) \ No newline at end of file
diff --git a/pit/test/test8.pit b/pit/test/test8.pit
deleted file mode 100644
index 3b41d7a..0000000
--- a/pit/test/test8.pit
+++ /dev/null
@@ -1,2 +0,0 @@
-(defun! foo (x) (+ x 1))
-(foo 2) \ No newline at end of file
diff --git a/pit/test/test9.pit b/pit/test/test9.pit
deleted file mode 100644
index daf1686..0000000
--- a/pit/test/test9.pit
+++ /dev/null
@@ -1,2 +0,0 @@
-(defun! foo (x) x)
-(foo 1) \ No newline at end of file
diff --git a/pit/test/thebug.pit b/pit/test/thebug.pit
deleted file mode 100644
index ad87bd7..0000000
--- a/pit/test/thebug.pit
+++ /dev/null
@@ -1,9 +0,0 @@
-(defun! foo (x)
- (lambda (y)
- (+ x y)))
-
-(setq! bar (foo 10))
-(setq! baz (foo 100))
-
-(print! (funcall bar 4))
-
diff --git a/pit/test/thebug2.pit b/pit/test/thebug2.pit
deleted file mode 100644
index 2376ff8..0000000
--- a/pit/test/thebug2.pit
+++ /dev/null
@@ -1,13 +0,0 @@
-
-(setq! z 40)
-(setq! f
- (lambda (x)
- (lambda (y)
- (lambda (w)
- (+
- (funcall (lambda (z) (+ x y z)) 3)
- w
- z)))))
-(let ((z 20))
- (print! (funcall (funcall (funcall f 1) 2) 3)))
-
diff --git a/pit/test/x86.pit b/pit/test/x86.pit
deleted file mode 100644
index 2aa8d89..0000000
--- a/pit/test/x86.pit
+++ /dev/null
@@ -1,451 +0,0 @@
-(defun! x86/split16le (w)
- "Split the 16-bit W16 into a little-endian list of 8-bit integers."
- (list
- (bitwise/and 0xff w)
- (bitwise/and 0xff (bitwise/rshift w 8))))
-
-(defun! x86/split32le (w)
- "Split the 32-bit W32 into a little-endian list of 8-bit integers."
- (list
- (bitwise/and 0xff w)
- (bitwise/and 0xff (bitwise/rshift w 8))
- (bitwise/and 0xff (bitwise/rshift w 16))
- (bitwise/and 0xff (bitwise/rshift w 24))))
-
-(defun! x86/register-1byte? (r)
- "Return the register index for 1-byte register R."
- (case r
- (al 0) (cl 1) (dl 2) (bl 3)
- (ah 4) (ch 5) (dh 6) (bh 7)
- (r8b 8) (r9b 9) (r10b 10) (r11b 11)
- (r12b 12) (r13b 13) (r14b 14) (r15b 15)))
-
-(defun! x86/register-2byte? (r)
- "Return the register index for 2-byte register R."
- (case r
- (ax 0) (cx 1) (dx 2) (bx 3)
- (sp 4) (bp 5) (si 6) (di 7)
- (r8w 8) (r9w 9) (r10w 10) (r11w 11)
- (r12w 12) (r13w 13) (r14w 14) (r15w 15)))
-
-(defun! x86/register-4byte? (r)
- "Return the register index for 4-byte register R."
- (case r
- (eax 0) (ecx 1) (edx 2) (ebx 3)
- (esp 4) (ebp 5) (esi 6) (edi 7)
- (r8d 8) (r9d 9) (r10d 10) (r11d 11)
- (r12d 12) (r13d 13) (r14d 14) (r15d 15)))
-
-(defun! x86/register-8byte? (r)
- "Return the register index for 8-byte register R."
- (case r
- (rax 0) (rcx 1) (rdx 2) (rbx 3)
- (rsp 4) (rbp 5) (rsi 6) (rdi 7)
- (r8 8) (r9 9) (r10 10) (r11 11)
- (r12 12) (r13 13) (r14 14) (r15 15)))
-
-(defun! x86/register? (r)
- "Return the register index of R."
- (or
- (x86/register-1byte? r)
- (x86/register-2byte? r)
- (x86/register-4byte? r)
- (x86/register-8byte? r)))
-
-(defun! x86/register-extended? (r)
- "Return non-nil if R is an extended register."
- (list/contains? r
- '( r8b r9b r10b r11b r12b r13b r14b r15b
- r8w r9w r10w r11w r12w r13w r14w r15w
- r8d r9d r10d r11d r12d r13d r14d r15d
- r8 r9 r10 r11 r12 r13 r14 r15)))
-
-(defun! x86/integer-fits-in-bits? (bits x)
- "Determine if X fits in BITS."
- (if (integer? x)
- (let ((leftover (bitwise/rshift x bits)))
- (eq? leftover 0))))
-(defun! x86/operand-immediate-fits? (sz x)
- "Determine if immediate operand X fits in SZ."
- (let
- ((bits
- (or
- (case sz
- ("b" 8) ("c" 16) ("d" 32) ("i" 16)
- ("j" 32) ("q" 64) ("v" 64) ("w" 16)
- ("y" 64) ("z" 32))
- (error! "unknown operand pattern size"))))
- (x86/integer-fits-in-bits? bits x)))
-
-(defun! x86/operand-register-fits? (sz r)
- "Determine if register operand R fits in SZ."
- (case sz
- ("b" (x86/register-1byte? r))
- ("c" (or (x86/register-1byte? r) (x86/register-2byte? r)))
- ("d" (x86/register-4byte? r))
- ("i" (x86/register-2byte? r))
- ("j" (x86/register-4byte? r))
- ("q" (x86/register-8byte? r))
- ("v" (or (x86/register-2byte? r) (x86/register-4byte? r) (x86/register-8byte? r)))
- ("w" (x86/register-2byte? r))
- ("y" (or (x86/register-4byte? r) (x86/register-8byte? r)))
- ("z" (or (x86/register-2byte? r) (x86/register-4byte? r)))))
-
-(defun! x86/memory-operand-base (m)
- (and
- (eq? (car m) 'mem)
- (car (cdr m))))
-(defun! x86/memory-operand-off (m)
- (and
- (eq? (car m) 'mem)
- (or (car (cdr (cdr m))) 0)))
-
-(defun! x86/operand-memory-location? (op)
- "Return non-nil if OP represents a memory location."
- (let ( (base (x86/memory-operand-base op))
- (off (x86/memory-operand-off op)))
- (and
- (or (x86/register-4byte? base) (x86/register-8byte? base))
- (integer? off))))
-
-(defun! x86/operand-match? (pat op)
- "Determine if operand OP matches PAT."
- (cond
- ((symbol? pat) (eq? pat op))
- ((cons? pat) (list/contains? op pat))
- ((bytes? pat)
- (let ( (loc (bytes/range 0 1 pat))
- (sz (bytes/range 1 (bytes/len pat) pat)))
- (cond
- ((or (equal? loc "I") (equal? loc "J")) (x86/operand-immediate-fits? sz op))
- ((or (equal? loc "G") (equal? loc "R")) (x86/operand-register-fits? sz op))
- ((equal? loc "M") (x86/operand-memory-location? op))
- ((equal? loc "E")
- (or (x86/operand-register-fits? sz op) (x86/operand-memory-location? op)))
- (t (error! "unknown operand pattern location")))))))
-
-(defun! x86/operand-size (op)
- "Return the minimum power-of-2 size in bytes that contains OP."
- (cond
- ((symbol? op)
- (cond
- ((x86/register-1byte? op) 1)
- ((x86/register-2byte? op) 2)
- ((x86/register-4byte? op) 4)
- ((x86/register-8byte? op) 8)
- (t (error! "attempted to take size of unknown register"))))
- ((integer? op)
- (cond
- ((x86/integer-fits-in-bits? 8 op) 1)
- ((x86/integer-fits-in-bits? 16 op) 2)
- ((x86/integer-fits-in-bits? 32 op) 4)
- ((x86/integer-fits-in-bits? 64 op) 8)
- (t (error! "attempted to take size of too-large immediate"))))
- ((x86/operand-memory-location? op) 1)
- (t (error! "attempted to take size of unknown operand"))))
-
-(defstruct! x86/ins
- operand-size-prefix
- address-size-prefix
- rex-w
- rex-r
- rex-x
- rex-b
- opcode
- modrm-mod
- modrm-reg
- modrm-rm
- disp ;; pair of size and value
- imm ;; pair of size and value
- )
-
-(defun! x86/ins-bytes (ins)
- "Return a list of bytes encoding INS."
- (let ( (opcode (x86/ins/get-opcode ins))
- (rex-w (x86/ins/get-rex-w ins))
- (rex-r (x86/ins/get-rex-r ins))
- (rex-x (x86/ins/get-rex-x ins))
- (rex-b (x86/ins/get-rex-b ins))
- (modrm-mod (x86/ins/get-modrm-mod ins))
- (modrm-reg (x86/ins/get-modrm-reg ins))
- (modrm-rm (x86/ins/get-modrm-rm ins))
- (disp (x86/ins/get-disp ins))
- (imm (x86/ins/get-imm ins)))
- (list/append
- (if (x86/ins/get-operand-size-prefix ins) '(0x66))
- (if (x86/ins/get-address-size-prefix ins) '(0x67))
- (if (or rex-w rex-r rex-x rex-b)
- (list
- (bitwise/or
- 0x40
- (if rex-w 0b1000 0)
- (if rex-r 0b0100 0)
- (if rex-x 0b0010 0)
- (if rex-b 0b0001 0))))
- (cond
- ((not opcode) (error! "no opcode for instruction"))
- ((cons? opcode) opcode)
- ((integer? opcode) (list opcode))
- (t (error! "malformed opcode for instruction")))
- (if (or modrm-mod modrm-reg modrm-rm)
- (list
- (bitwise/or
- (bitwise/lshift (or modrm-mod 0) 6)
- (bitwise/lshift (or modrm-reg 0) 3)
- (or modrm-rm 0))))
- (if disp
- (cond
- ((eq? (car disp) 1) (list (cdr disp)))
- ((eq? (car disp) 4) (x86/split32le (cdr disp)))
- (t (error! "malformed displacement for instruction"))))
- (if imm
- (cond
- ((eq? (car imm) 1) (list (cdr imm)))
- ((eq? (car imm) 2) (x86/split16le (cdr imm)))
- ((eq? (car imm) 4) (x86/split32le (cdr imm)))
- (t (error! "malformed immediate for instruction")))))))
-
-(defun! x86/instruction-update-sizes (ins ops default-size)
- "Update INS to account for the sizes of OPS.
-DEFAULT-SIZE is the default operand size."
- (let ((defsz (or default-size 4)))
- (if (> (list/len ops) 0)
- (let ((regs (list/uniq (list/map 'x86/operand-size (list/filter 'x86/register? ops)))))
- (if (> (list/len regs) 1)
- (error! "invalid mix of register sizes in operands"))
- (let ((sz (if (eq? (list/len regs) 0) defsz (car regs))))
- (cond
- ((eq? sz 1) nil)
- ((eq? defsz sz) nil)
- ((and (not (eq? defsz 2)) (eq? sz 2)) (x86/ins/set-operand-size-prefix! ins t))
- ((and (not (eq? defsz 8)) (eq? sz 8)) (x86/ins/set-rex-w! ins t))
- (t (error! "unable to encode operands with default size")))
- sz)))))
-
-(defun! x86/instruction-update-operand (esz ins pat op)
- "Update INS to account for an operand OP according to PAT.
-The effective operand size is ESZ."
- (cond
- ((bytes? pat)
- (let ((loc (bytes/range 0 1 pat)))
- (cond
- ((equal? loc "I")
- (let ((immsz (if (>= esz 4) 4 esz)))
- (if (not (x86/integer-fits-in-bits? (* 8 immsz) op))
- (error! "Immediate too large" op))
- (x86/ins/set-imm! ins (cons immsz op))))
- ((equal? loc "J")
- (let ((immsz (if (eq? esz 1) 1 4)))
- (if (not (x86/integer-fits-in-bits? (* 8 immsz) op))
- (error! "jump displacement too large"))
- (x86/ins/set-disp! ins (cons immsz op))))
- ((equal? loc "G")
- (x86/ins/set-modrm-reg! ins
- (or (x86/register? op) (error "Invalid register: %s" op))))
- ((or (equal? loc "R") (and (equal? loc "E") (x86/register? op)))
- (x86/ins/set-modrm-mod! ins 0b11)
- (x86/ins/set-modrm-rm! ins
- (or (x86/register? op) (error "Invalid register: %s" op))))
- ((or (equal? loc "M") (and (equal? loc "E") (x86/operand-memory-location? op)))
- (let ( (base (x86/memory-operand-base op))
- (off (x86/memory-operand-off op)))
- (cond
- ((eq? base 'eip)
- (x86/ins/set-modrm-rm! ins 0b101)
- (x86/ins/set-modrm-mod! ins 0b00)
- (x86/ins/set-disp! ins (cons 4 off))
- (x86/ins/set-address-size-prefix! ins t))
- ((eq? base 'rip)
- (x86/ins/set-modrm-rm! ins 0b101)
- (x86/ins/set-modrm-mod! ins 0b00)
- (x86/ins/set-disp! ins (cons 4 off)))
- (t
- (x86/ins/set-modrm-rm! ins
- (or
- (x86/register-4byte? base)
- (x86/register-8byte? base)
- (error! "invalid base register")))
- (if (x86/register-4byte? base)
- (x86/ins/set-address-size-prefix! ins t))
- (cond
- ((x86/integer-fits-in-bits? 8 off)
- (x86/ins/set-disp! ins (cons 1 off))
- (x86/ins/set-modrm-mod! ins 0b01))
- ((x86/integer-fits-in-bits? 32 off)
- (x86/ins/set-disp! ins (cons 4 off))
- (x86/ins/set-modrm-mod! ins 0b10))
- (t (error! "invalid offset")))))))
- (t (error! "invalid operand location code")))))))
-
-(defun! x86/default-instruction-handler (opcode & kwargs)
- "Return an instruction handler for OPCODE.
-The instruction handler will run POSTHOOK on the instruction at the end.
-DEFAULT-SIZE is the default operand size."
- (let ( (posthook (plist/get :posthook kwargs))
- (default-size (plist/get :default-size kwargs)))
- (lambda (pats ops)
- (let ((ret (x86/ins/new :opcode opcode)))
- (let ((esz
- (or (x86/instruction-update-sizes ret ops default-size)
- (error! "malformed size for operands"))))
- (list/zip-with
- (lambda (it other)
- (x86/instruction-update-operand esz ret it other))
- pats
- ops))
- (if posthook
- (funcall posthook ret ops))
- ret))))
-
-(defun! x86/instruction-handler-jcc (opcode immsz)
- "Return an instruction handler for a Jcc instruction at OPCODE.
-IMMSZ is the size of the displacement from RIP."
- (lambda (_pats ops)
- (let ((ret (x86/ins/new :opcode opcode)))
- (x86/ins/set-disp! ret (cons immsz (car ops)))
- ret)))
-
-(defun! x86/generate-handlers-arith (opbase group1reg)
- "Return handlers for an arithmetic mnemonic starting at OPBASE.
-The REG value in ModR/M is indicated by GROUP1REG."
- (list
- (cons '("Eb" "Gb") (x86/default-instruction-handler (+ opbase 0)))
- (cons '("Ev" "Gv") (x86/default-instruction-handler (+ opbase 1)))
- (cons '("Gb" "Eb") (x86/default-instruction-handler (+ opbase 2)))
- (cons '("Gv" "Ev") (x86/default-instruction-handler (+ opbase 3)))
- (cons '(al "Ib") (x86/default-instruction-handler (+ opbase 4)))
- (cons '((ax eax rax) "Iz") (x86/default-instruction-handler (+ opbase 5)))
- (cons '("Eb" "Ib")
- (x86/default-instruction-handler 0x80
- :posthook (lambda (ins _) (x86/ins/set-modrm-reg! ins group1reg))))
- (cons '("Ev" "Iz")
- (x86/default-instruction-handler 0x81
- :posthook (lambda (ins _) (x86/ins/set-modrm-reg! ins group1reg))))
- (cons '("Ev" "Ib")
- (x86/default-instruction-handler 0x83
- :posthook (lambda (ins _) (setf (x86/ins-modrm-reg ins) group1reg))))))
-
-(setq! x86/registers-+reg-base
- '( (+rb . (al cl dl bl ah ch dh bh))
- (+rw . (ax cx dx bx sp bp si di))
- (+rd . (eax ecx edx ebx esp ebp esi edi))
- (+rq . (rax rcx rdx rbx rsp rbp rsi rdi))))
-(setq! x86/registers-+reg-extended
- '( (+rw . (r8b r9b r10b r11b r12b r13b r14b r15b))
- (+rw . (r8w r9w r10w r11w r12w r13w r14w r15w))
- (+rd . (r8d r9d r10d r11d r12d r13d r14d r15d))
- (+rq . (r8 r9 r10 r11 r12 r13 r14 r15))))
-(defun! x86/generate-handlers-opcode-+reg (opbase extraops addends & args)
- "Generate handlers for a family of opcodes that uses the +reg encoding.
-OPBASE is the base opcode.
-EXTRAOPS are additional operands after the register operand.
-ADDENDS is a list of symbols like +rw, +rq etc. that denote allowed registers.
-ARGS are passed verbatim to `u/x86/default-instruction-handler."
- (list/map
- (lambda (it)
- (let ( (abase (list/map (lambda (a) (list/nth it (alist/get a x86/registers-+reg-base))) addends))
- (aext (list/map (lambda (a) (list/nth it (alist/get a x86/registers-+reg-extended))) addends)))
- (cons
- (cons (list/append abase aext) extraops)
- (apply 'x86/default-instruction-handler (cons (+ opbase it) args)))))
- (list/iota 8)))
-
-(setq!
- x86/mnemonic-table
- (list
- (cons 'add (x86/generate-handlers-arith 0x00 0))
- (cons 'or (x86/generate-handlers-arith 0x08 1))
- (cons 'adc (x86/generate-handlers-arith 0x10 2))
- (cons 'sbb (x86/generate-handlers-arith 0x18 3))
- (cons 'and (x86/generate-handlers-arith 0x20 4))
- (cons 'sub (x86/generate-handlers-arith 0x28 5))
- (cons 'xor (x86/generate-handlers-arith 0x30 6))
- (cons 'cmp (x86/generate-handlers-arith 0x38 7))
- (cons 'push
- (x86/generate-handlers-opcode-+reg 0x50 '() '(+rw +rq)
- :default-size 8
- :posthook (lambda (ins ops) (x86/ins/set-rex-b! ins (x86/register-extended? (car ops))))))
- (cons 'pop
- (x86/generate-handlers-opcode-+reg 0x58 '() '(+rw +rq)
- :default-size 8
- :posthook (lambda (ins ops) (x86/ins/set-rex-b! ins (x86/register-extended? (car ops))))))
- (list 'jo
- (cons '("Jb") (x86/instruction-handler-jcc 0x70 1))
- (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x80) 4)))
- (list 'jno
- (cons '("Jb") (x86/instruction-handler-jcc 0x71 1))
- (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x81) 4)))
- (list 'jb
- (cons '("Jb") (x86/instruction-handler-jcc 0x72 1))
- (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x82) 4)))
- (list 'jnb
- (cons '("Jb") (x86/instruction-handler-jcc 0x73 1))
- (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x83) 4)))
- (list 'jz
- (cons '("Jb") (x86/instruction-handler-jcc 0x74 1))
- (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x84) 4)))
- (list 'jnz
- (cons '("Jb") (x86/instruction-handler-jcc 0x75 1))
- (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x85) 4)))
- (list 'jbe
- (cons '("Jb") (x86/instruction-handler-jcc 0x76 1))
- (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x86) 4)))
- (list 'jnbe
- (cons '("Jb") (x86/instruction-handler-jcc 0x77 1))
- (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x87) 4)))
- (list 'js
- (cons '("Jb") (x86/instruction-handler-jcc 0x78 1))
- (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x88) 4)))
- (list 'jns
- (cons '("Jb") (x86/instruction-handler-jcc 0x79 1))
- (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x89) 4)))
- (list 'jp
- (cons '("Jb") (x86/instruction-handler-jcc 0x7a 1))
- (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x8a) 4)))
- (list 'jnp
- (cons '("Jb") (x86/instruction-handler-jcc 0x7b 1))
- (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x8b) 4)))
- (list 'jl
- (cons '("Jb") (x86/instruction-handler-jcc 0x7c 1))
- (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x8c) 4)))
- (list 'jnl
- (cons '("Jb") (x86/instruction-handler-jcc 0x7d 1))
- (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x8d) 4)))
- (list 'jle
- (cons '("Jb") (x86/instruction-handler-jcc 0x7e 1))
- (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x8e) 4)))
- (list 'jnle
- (cons '("Jb") (x86/instruction-handler-jcc 0x7f 1))
- (cons '("Jz") (x86/instruction-handler-jcc '(0x0f 0x8f) 4)))
- (cons 'mov
- (x86/generate-handlers-opcode-+reg 0xb0 '("Ib") '(+rb)
- :posthook (lambda (ins ops) (x86/ins/set-rex-b! ins (x86/register-extended? (car ops))))))
- (cons 'mov
- (x86/generate-handlers-opcode-+reg 0xb8 '("Iv") '(+rw +rd +rq)
- :posthook (lambda (ins ops) (x86/ins/set-rex-b! ins (x86/register-extended? (car ops))))))
- (list 'jmp
- (cons '("Ev")
- (x86/default-instruction-handler 0xff
- :default-size 8
- :posthook (lambda (ins _) (setf (u/x86/ins-modrm-reg ins) 4)))))
- (list 'syscall
- (cons '() (lambda (_ _) (x86/ins/new :opcode '(0x0f 0x05)))))
- ))
-
-(defun! x86/asm (op)
- "Assemble OP to an instruction."
- (let ((mnem (car op)) (operands (cdr op)))
- (let ((variants (or (alist/get mnem x86/mnemonic-table) (error! "unknown mnemonic"))))
- (let ((v
- (list/find
- (lambda (it)
- (and (eq? (list/len (car it)) (list/len operands))
- (list/all? (lambda (x) x) (list/zip-with 'x86/operand-match? (car it) operands))))
- variants)))
- (if (and v (function? (cdr v)))
- (funcall (cdr v) (car v) operands)
- (error! "could not identify instruction"))))))
-
-(setq! test-ins (x86/asm '(syscall)))
-(print! test-ins)
-(print! (x86/ins-bytes test-ins))
diff --git a/pit/test/y.pit b/pit/test/y.pit
deleted file mode 100644
index 5e9218b..0000000
--- a/pit/test/y.pit
+++ /dev/null
@@ -1,5 +0,0 @@
-(setq! Y
- (lambda (f)
- (funcall
- (lambda (x) (funcall f (funcall x x)))
- (lambda (x) (funcall f (funcall x x))))))