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
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
|
; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
; Part of Scheme 48 1.9. See file COPYING for notices and license.
; Authors: Richard Kelsey, Jonathan Rees, Mike Sperber, Marcus Crestani
; Calling C procedures.
; The arguments have been pushed on the stack after the procedure.
; *stack* = procedure name arg1 ... argN rest-list N+1 total-nargs
;
; The procedure must be an external binding whose value is a pointer-sized
; code-vector. If it is, we actually do the call.
;
; The REMOVE-CURRENT-FRAME call pops all of our values off of the stack.
; In fact we still use them there for a moment (see s48_external_call() in
; external.c) but all of the values are fetched from the stack before
; anything new is pushed on.
(define-primitive call-external-value ()
(lambda ()
(let* ((nargs (extract-fixnum (pop)))
(stack-nargs (extract-fixnum (pop)))
(rest-list (pop)))
(if (< maximum-external-call-args
(- nargs 2)) ; procedure & name
(raise-exception too-many-arguments-to-external-procedure
0
(stack-ref (- stack-nargs 1))
nargs)
(begin
(do ((rest-list rest-list (vm-cdr rest-list)))
((vm-eq? rest-list null))
(push (vm-car rest-list)))
(let ((proc (stack-ref (- nargs 1)))
(name (stack-ref (- nargs 2)))
(args (pointer-to-stack-arguments)))
(if (and (vm-string? name)
(code-vector? proc)
(= (code-vector-length proc)
(cells->bytes 1)))
(begin
(remove-current-frame)
(let ((result (external-call proc name (- nargs 2) args)))
(cond (*external-exception?*
(set! *external-exception?* #f)
(goto raise *external-exception-nargs*))
(else
(goto continue-with-value result 0)))))
(raise-exception wrong-type-argument 0 proc name))))))))
(define-primitive call-external-value-2 ()
(lambda ()
(let* ((nargs (extract-fixnum (pop)))
(stack-nargs (extract-fixnum (pop)))
(rest-list (pop)))
(if (< maximum-external-call-args
(- nargs 2)) ; procedure & name
(raise-exception too-many-arguments-to-external-procedure
0
(stack-ref (- stack-nargs 1))
nargs)
(begin
(do ((rest-list rest-list (vm-cdr rest-list)))
((vm-eq? rest-list null))
(push (vm-car rest-list)))
(let ((proc (stack-ref (- nargs 1)))
(name (stack-ref (- nargs 2)))
(args (pointer-to-stack-arguments)))
(if (and (vm-string? name)
(code-vector? proc)
(= (code-vector-length proc)
(cells->bytes 1)))
(begin
(remove-current-frame)
(let ((result (external-call-2 proc name (- nargs 2) args)))
(cond (*external-exception?*
(set! *external-exception?* #f)
(goto raise *external-exception-nargs*))
(else
(goto continue-with-value result 0)))))
(raise-exception wrong-type-argument 0 proc name))))))))
;----------------
; Raising exceptions from C.
; True if the C procedure is raising an exception instead of doing a normal
; return.
(define *external-exception?* #f)
; The number of arguments being passed to the exception handler.
(define *external-exception-nargs*)
; These are for exceptions raised by external code. They work pretty
; much in the same way as other VM instructions raise exceptions.
; Note that this doesn't actually perform the raise; it just sets
; *EXTERNAL-EXCEPTION?* to be true, so that the EXTERNAL-CALL procedure
; will do the raise.
;
; If you extend the maximum number of arguments, be sure to adjust the
; definition of STACK-SLACK in stack.scm. It needs to know the maximum
; number of values pushed by an exception handler, which is the number
; of arguments pushed here, plus the procedure.
(define (s48-setup-external-exception why nargs)
(push-exception-setup! why 1) ; 1 = one-byte instruction
(if (< 10 nargs)
(error "too many arguments from external exception"))
(set! *external-exception-nargs* nargs)
(set! *external-exception?* #t))
; The external code needs to piggyback an exception on top of one already
; being raised. We increase the argument count and return the old exception.
(define (s48-resetup-external-exception new-why additional-nargs)
(let* ((old-nargs *external-exception-nargs*)
(old-why (stack-ref old-nargs)))
(stack-set! old-nargs (enter-fixnum new-why))
(set! *external-exception-nargs* (+ old-nargs additional-nargs))
old-why))
; Shared bindings
(define-primitive find-undefined-imported-bindings ()
(lambda ()
(let loop ((first? #t))
(let ((vector (s48-gather-objects shared-binding-undefined?
for-each-imported-binding)))
(cond ((not (false? vector))
(goto return vector))
(first?
;; if the result vector couldn't be created force a
;; major collection and try again once.
(s48-collect #t)
(loop #f))
(else
(raise-exception heap-overflow 0)))))))
(define-consing-primitive lookup-shared-binding (string-> boolean->)
(lambda (ignore)
shared-binding-size)
(lambda (name is-import? key)
(goto return
(if is-import?
(lookup-imported-binding name key)
(lookup-exported-binding name key)))))
(define-primitive undefine-shared-binding (string-> boolean->)
(lambda (name is-import?)
(undefine-shared-binding! (if is-import?
(s48-imported-bindings)
(s48-exported-bindings))
name)
(goto continue 0)))
|
