forked from g000001/Starlisp-simulator
-
Notifications
You must be signed in to change notification settings - Fork 0
/
unportable-proclaim.lisp
114 lines (91 loc) · 3.98 KB
/
unportable-proclaim.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
;;; -*- SYNTAX: COMMON-LISP; MODE: LISP; BASE: 10; PACKAGE: *SIM-I; MUSER: YES -*-
(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.
;;; #+*LISP-HARDWARE
;;; (import '(proclaimed-type proclaimed-ftype proclaimed-declaration-p proclaimed-special-p check-paris-restriction)
;;; (find-package 'slc)
;;; )
;;;
;;; #+*LISP-HARDWARE
;;; (proclaim '(special slc::*compiler-options* slc::*slc-function-types*))
;;;
;;;
;;;
;;; #+*LISP-HARDWARE
;;; (eval-when (:compile-toplevel :load-toplevel :execute)
;;; (setf (symbol-function 'slc::canonical-type) 'canonical-type)
;;; )
(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar *maximum-integer-length* #+*LISP-HARDWARE cm:*maximum-integer-length* #+*LISP-SIMULATOR 128)
(defvar *maximum-signficand-length* #+*LISP-HARDWARE cm:*maximum-significand-length* #+*LISP-SIMULATOR 96)
(defvar *maximum-exponent-length* #+*LISP-HARDWARE cm:*maximum-exponent-length* #+*LISP-SIMULATOR 32)
)
#+*LISP-HARDWARE
(eval-when (load eval compile)
(defun *defun-maybe (function-name arguments)
`(let* ((old-*temp-pvar-list* *temp-pvar-list*)
(place-holder (cm:allocate-stack-field 0)))
(maybe-return-pvar place-holder (,function-name ,@arguments) old-*temp-pvar-list*)))
(defun *defun-yes (function-name arguments)
`(let ((place-holder (cm:allocate-stack-field 0)))
(values (move-pvar-to-place-holder place-holder (,function-name ,@arguments)))))
(defun *defun-no (function-name arguments)
`(let ((*lisp-i::*temp-pvar-list* *lisp-i::*temp-pvar-list*)
(*lisp-i::place-holder (cm:allocate-stack-field 0)))
(prog1 (,function-name ,@arguments)
(cm:deallocate-upto-stack-field *lisp-i::place-holder))))
(defun *defun-type (function)
(let* ((ftype (proclaimed-ftype function)) (return-type (if ftype (caddr ftype))))
(if ftype
;; return type must be canonical, (which it is supposed to be
(if (or (eq return-type 'pvar)
(and (consp return-type) (eq (car return-type) 'pvar)))
:yes
(if (and (consp return-type) (member (car return-type) '(satisfies and or not member values)))
:dont-know
:no))
:dont-know)))
(defun proclaim-*defun-1 (function-name)
(let ((old-source-file-name (get function-name :source-file-name)))
(setf (*lisp-i::get-*defun-function function-name) (make-*defun-function function-name))
(setf (macro-function function-name)
#'(lambda (%form% %environment% &aux (args (cdr %form%)))
(or (funcall '*lisp-compiler-hook %form% %environment%)
(case (*defun-type function-name)
(:dont-know (*defun-maybe (make-*defun-function function-name) args))
(:no (*defun-no (make-*defun-function function-name) args))
(:yes (*defun-yes (make-*defun-function function-name) args))))))
(setf (get function-name :source-file-name) old-source-file-name))))
#+*LISP-SIMULATOR
(eval-when (load eval compile)
(defun proclaim-*defun-1 (function-name)
(when (not (macro-function function-name))
(let ((old-temp-pvar-list-symbol (gensym "OLD-TEMP-PVAR-LIST-")))
(setf (macro-function function-name)
#'(lambda (form environment)
(declare (ignore environment))
`(let ((,old-temp-pvar-list-symbol *temp-pvar-list*))
(handle-returning-pvar
(,(make-*defun-function function-name) ,@(cdr form))
,old-temp-pvar-list-symbol
nil
)))))))
)
(defmacro proclaim-all-*defuns ()
`(progn
,@(mapcan
#'(lambda (symbol)
(let ((type (get symbol :starlisp-type)))
(when (eq type :*defun)
`((*proclaim '(*defun ,symbol)))
)))
*all-external-symbols*
)))
(proclaim-all-*defuns)