/
type-system-basics.lisp
119 lines (92 loc) · 3.51 KB
/
type-system-basics.lisp
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
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
(in-package :*sim-i)
;;;> *+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+
;;;>
;;;> The Thinking Machines *Lisp Simulator is in the public domain.
;;;> You are free to do whatever you like with it, including but
;;;> not limited to distributing, modifying, and copying.
;;;>
;;;> *+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+
;;; Author: JP Massar.
(eval-when (:compile-toplevel :load-toplevel :execute)
(defconstant short-float-mantissa 15)
(defconstant short-float-exponent 8)
(defconstant single-float-mantissa 23)
(defconstant single-float-exponent 8)
(defconstant double-float-mantissa 52)
(defconstant double-float-exponent 11)
(defconstant long-float-mantissa 74)
(defconstant long-float-exponent 21)
(defconstant extended-float-mantissa 96)
(defconstant extended-float-exponent 31)
(defconstant nbits-per-lisp 4)
)
(defun error-not-cpt (type)
(error "~S is not a canonical pvar type." type))
(defun error-if-not-cpt (type)
(unless (and (consp type) (eq (car type) 'pvar))
(error-not-cpt type)
))
;;This will return one of boolean, unsigned-byte, signed-byte, defined-float,
;; complex, string-char, character, array, structure, t, front-end, or *.
(defun canonical-pvar-element-type (type)
(error-if-not-cpt type)
(if (consp (cadr type)) (caadr type) (cadr type))
)
(defun array-pvar-type-p (type)
(error-if-not-cpt type)
(and (consp (cadr type)) (eq (caadr type) 'array)))
(defun structure-pvar-type-p (type)
(error-if-not-cpt type)
(and (consp (cadr type)) (eq (caadr type) 'structure)))
(defun array-pvar-type-dimensions (type)
(unless (array-pvar-type-p type) (error-not-cpt type))
(caddr (cadr type)))
(defun array-pvar-type-element-type (type)
(unless (array-pvar-type-p type) (error-not-cpt type))
(cadr (cadr type)))
(defun structure-pvar-type-name (type)
(unless (structure-pvar-type-p type) (error-not-cpt type))
(cadr (cadr type)))
(defun float-pvar-type-p (type)
(error-if-not-cpt type)
(and (consp (cadr type)) (eq (caadr type) 'defined-float)))
(defun complex-pvar-type-p (type)
(error-if-not-cpt type)
(and (consp (cadr type)) (eq (caadr type) 'complex)))
(defun boolean-pvar-type-p (type)
(error-if-not-cpt type)
(eq (cadr type) 'boolean))
(defun front-end-pvar-type-p (type)
(error-if-not-cpt type)
(eq (cadr type) 'front-end))
(defun general-pvar-type-p (type)
(error-if-not-cpt type)
(eq (cadr type) 't))
(defun string-char-pvar-type-p (type)
(error-if-not-cpt type)
(eq (cadr type) 'string-char))
(defun character-pvar-type-p (type)
(error-if-not-cpt type)
(eq (cadr type) 'character))
(defun signed-pvar-type-p (type)
(error-if-not-cpt type)
(and (consp (cadr type)) (eq (caadr type) 'signed-byte)))
(defun unsigned-pvar-type-p (type)
(error-if-not-cpt type)
(and (consp (cadr type)) (eq (caadr type) 'unsigned-byte)))
(defun float-pvar-type-mantissa (type)
(unless (float-pvar-type-p type)
(error "~S is not a canonical pvar float type." type))
(cadr (cadr type)))
(defun float-pvar-type-exponent (type)
(unless (float-pvar-type-p type)
(error "~S is not a canonical pvar float type." type))
(caddr (cadr type)))
(defun complex-pvar-type-mantissa (type)
(unless (complex-pvar-type-p type)
(error "~S is not a canonical pvar complex type." type))
(cadr (cadadr type)))
(defun complex-pvar-type-exponent (type)
(unless (complex-pvar-type-p type)
(error "~S is not a canonical pvar complex type." type))
(caddr (cadadr type)))