summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2012-04-26 22:56:45 +0200
committerAndy Wingo <wingo@pobox.com>2012-04-26 22:56:45 +0200
commitc46e0a8a598a16b8f68b5492a13e4032b93f21f9 (patch)
treeb57374184dc4715a32393b53866263a55ebc01b7 /module
parente7501d4a682cc2b430514280834dfc68b97f2be2 (diff)
parentde1eb420a5a95b17e85b19c4d98c869036e9ecb0 (diff)
downloadguile-c46e0a8a598a16b8f68b5492a13e4032b93f21f9.tar.gz
Merge commit 'de1eb420a5a95b17e85b19c4d98c869036e9ecb0'
Conflicts: module/language/tree-il/primitives.scm test-suite/tests/tree-il.test
Diffstat (limited to 'module')
-rw-r--r--module/language/tree-il/primitives.scm121
1 files changed, 61 insertions, 60 deletions
diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm
index 8aecb8517..73d3d69e6 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -29,8 +29,12 @@
expand-primitives!
effect-free-primitive? effect+exception-free-primitive?
constructor-primitive? accessor-primitive?
- singly-valued-primitive? equality-primitive?))
+ singly-valued-primitive? equality-primitive?
+ bailout-primitive?
+ negate-primitive))
+;; When adding to this, be sure to update *multiply-valued-primitives*
+;; if appropriate.
(define *interesting-primitive-names*
'(apply @apply
call-with-values @call-with-values
@@ -45,8 +49,12 @@
+ * - / 1- 1+ quotient remainder modulo
ash logand logior logxor
not
- pair? null? list? symbol? vector? string? struct?
- nil?
+ pair? null? list? symbol? vector? string? struct? number? char? nil?
+
+ complex? real? rational? inf? nan? integer? exact? inexact? even? odd?
+
+ char<? char<=? char>=? char>?
+
acons cons cons*
list vector
@@ -70,6 +78,8 @@
@prompt call-with-prompt @abort abort-to-prompt
make-prompt-tag
+ throw error scm-error
+
string-length string-ref string-set!
struct-vtable make-struct struct-ref struct-set!
@@ -123,7 +133,7 @@
'(vector-ref
car cdr
memq memv
- struct-vtable struct-ref
+ struct-ref
string-ref
bytevector-u8-ref bytevector-s8-ref
bytevector-u16-ref bytevector-u16-native-ref
@@ -141,8 +151,10 @@
= < > <= >= zero?
+ * - / 1- 1+ quotient remainder modulo
not
- pair? null? list? symbol? vector? struct? string?
- nil?
+ pair? null? list? symbol? vector? struct? string? number? char? nil
+ complex? real? rational? inf? nan? integer? exact? inexact? even? odd?
+ char<? char<=? char>=? char>?
+ struct-vtable
string-length vector-length
;; These all should get expanded out by expand-primitives!.
caar cadr cdar cddr
@@ -158,64 +170,42 @@
'(values
eq? eqv? equal?
not
- pair? null? list? symbol? vector? struct? string?
+ pair? null? list? symbol? vector? struct? string? number? char?
acons cons cons* list vector))
-;; Primitives that only return one value.
-(define *singly-valued-primitives*
- '(eq? eqv? equal?
- memq memv
- = < > <= >= zero?
- + * - / 1- 1+ quotient remainder modulo
- ash logand logior logxor
- not
- pair? null? list? symbol? vector? acons cons cons*
- nil?
- list vector
- car cdr
- set-car! set-cdr!
- caar cadr cdar cddr
- caaar caadr cadar caddr cdaar cdadr cddar cdddr
- caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
- cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
- vector-ref vector-set!
- variable-ref variable-set!
- variable-bound?
- fluid-ref fluid-set!
- make-prompt-tag
- struct? struct-vtable make-struct struct-ref struct-set!
- string-length string-ref string-set!
- bytevector-u8-ref bytevector-u8-set!
- bytevector-s8-ref bytevector-s8-set!
- u8vector-ref u8vector-set! s8vector-ref s8vector-set!
- bytevector-u16-ref bytevector-u16-set!
- bytevector-u16-native-ref bytevector-u16-native-set!
- bytevector-s16-ref bytevector-s16-set!
- bytevector-s16-native-ref bytevector-s16-native-set!
- u16vector-ref u16vector-set! s16vector-ref s16vector-set!
- bytevector-u32-ref bytevector-u32-set!
- bytevector-u32-native-ref bytevector-u32-native-set!
- bytevector-s32-ref bytevector-s32-set!
- bytevector-s32-native-ref bytevector-s32-native-set!
- u32vector-ref u32vector-set! s32vector-ref s32vector-set!
- bytevector-u64-ref bytevector-u64-set!
- bytevector-u64-native-ref bytevector-u64-native-set!
- bytevector-s64-ref bytevector-s64-set!
- bytevector-s64-native-ref bytevector-s64-native-set!
- u64vector-ref u64vector-set! s64vector-ref s64vector-set!
- bytevector-ieee-single-ref bytevector-ieee-single-set!
- bytevector-ieee-single-native-ref bytevector-ieee-single-native-set!
- bytevector-ieee-double-ref bytevector-ieee-double-set!
- bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!
- f32vector-ref f32vector-set! f64vector-ref f64vector-set!))
+;; Primitives that don't always return one value.
+(define *multiply-valued-primitives*
+ '(apply @apply
+ call-with-values @call-with-values
+ call-with-current-continuation @call-with-current-continuation
+ call/cc
+ dynamic-wind
+ @dynamic-wind
+ values
+ @prompt call-with-prompt @abort abort-to-prompt))
+
+;; Procedures that cause a nonlocal, non-resumable abort.
+(define *bailout-primitives*
+ '(throw error scm-error))
+
+;; Negatable predicates.
+(define *negatable-primitives*
+ '((even? . odd?)
+ (exact? . inexact?)
+ (< . >=)
+ (> . <=)
+ (char<? . char>=?)
+ (char>? . char<=?)))
(define *equality-primitives*
'(eq? eqv? equal?))
(define *effect-free-primitive-table* (make-hash-table))
(define *effect+exceptions-free-primitive-table* (make-hash-table))
-(define *singly-valued-primitive-table* (make-hash-table))
(define *equality-primitive-table* (make-hash-table))
+(define *multiply-valued-primitive-table* (make-hash-table))
+(define *bailout-primitive-table* (make-hash-table))
+(define *negatable-primitive-table* (make-hash-table))
(for-each (lambda (x)
(hashq-set! *effect-free-primitive-table* x #t))
@@ -223,12 +213,19 @@
(for-each (lambda (x)
(hashq-set! *effect+exceptions-free-primitive-table* x #t))
*effect+exception-free-primitives*)
-(for-each (lambda (x)
- (hashq-set! *singly-valued-primitive-table* x #t))
- *singly-valued-primitives*)
(for-each (lambda (x)
(hashq-set! *equality-primitive-table* x #t))
*equality-primitives*)
+(for-each (lambda (x)
+ (hashq-set! *multiply-valued-primitive-table* x #t))
+ *multiply-valued-primitives*)
+(for-each (lambda (x)
+ (hashq-set! *bailout-primitive-table* x #t))
+ *bailout-primitives*)
+(for-each (lambda (x)
+ (hashq-set! *negatable-primitive-table* (car x) (cdr x))
+ (hashq-set! *negatable-primitive-table* (cdr x) (car x)))
+ *negatable-primitives*)
(define (constructor-primitive? prim)
(memq prim *primitive-constructors*))
@@ -238,10 +235,14 @@
(hashq-ref *effect-free-primitive-table* prim))
(define (effect+exception-free-primitive? prim)
(hashq-ref *effect+exceptions-free-primitive-table* prim))
-(define (singly-valued-primitive? prim)
- (hashq-ref *singly-valued-primitive-table* prim))
(define (equality-primitive? prim)
(hashq-ref *equality-primitive-table* prim))
+(define (singly-valued-primitive? prim)
+ (not (hashq-ref *multiply-valued-primitive-table* prim)))
+(define (bailout-primitive? prim)
+ (hashq-ref *bailout-primitive-table* prim))
+(define (negate-primitive prim)
+ (hashq-ref *negatable-primitive-table* prim))
(define (resolve-primitives! x mod)
(define local-definitions