rename

1 files changed, 47 insertions, 0 deletions

diff --git a/lib/SAHP/internal-chicken.scm b/lib/SAHP/internal-chicken.scm
new file mode 100644
index 0000000..992d98f
--- /dev/null
+++ b/lib/SAHP/internal-chicken.scm
@@ -0,0 +1,47 @@
+(define (%make-derived-SAHP desc)
+  (let ((proc (lambda (arg1 . arg-rest)
+                (call-SAHP desc (type-of arg1) (cons arg1 arg-rest)))))
+    (extend-procedure proc desc)))
+
+(define (make-new-SAHP)
+  (%make-derived-SAHP
+   (make-SAHP-descriptor (make-symbol-mapping)
+                         (make-parameter (make-symbol-mapping))
+                         (make-hash-table))))
+
+(define (SAHP? x)
+  (and (extended-procedure? x)
+       (SAHP-descriptor? (extract-SAHP-descriptor x))))
+
+(define extract-SAHP-descriptor procedure-data)
+
+(define (type-of x)
+  (cond
+    ((exact-integer? x) 'exact-integer)
+    ((integer? x) 'integer)
+    ((rational? x) 'rational)
+    ((real? x) 'real)
+    ((complex? x) 'complex)
+    ((number? x) 'number)
+    ((boolean? x) 'boolean)
+    ((char? x) 'char)
+    ((null? x) 'null)
+    ((pair? x) 'pair)
+    ((procedure? x) 'procedure)
+    ((symbol? x) 'symbol)
+    ((bytevector? x) 'bytevector)
+    ((eof-object? x) 'eof-object)
+    ((port? x) 'port)
+    ((string? x) 'string)
+    ((vector? x) 'vector)
+    ((record-instance? x) (record-instance-type x))
+    (else (error "cannot derive type of" x))))
+
+(define (subtypes type)
+  (case type
+    ((number) '(complex))
+    ((complex) '(real))
+    ((real) '(rational))
+    ((rational) '(integer))
+    ((integer) '(exact-integer))
+    (else '())))