blob: 992d98f64507e410ae5ad80e805fbbd81588677d (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
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 '())))
|
