scsh-0.6/scheme/vm/external-call.scm

; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.

; 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.

(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)); ignore 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)))
	      ; Push a header to keep the arguments from being scanned.
	      (push (make-header (enum stob vector)
				 (cells->bytes nargs)))
	      (if (and (vm-string? name)
		       (code-vector? proc)
		       (= (code-vector-length proc)
			  (cells->bytes 1)))
		  (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))))))))

;----------------
; 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-continuation! 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))

;----------------
; Two tables of shared bindings: those we import from the outside and those
; that we provide to the outside.

(define *imported-bindings*)
(define *exported-bindings*)

; When resuming a statically-linked image these tables are FALSE.

(define (install-shared-bindings!+gc imported-bindings exported-bindings)
  (receive (key imported-bindings exported-bindings)
      (ensure-space-saving-temps (* hash-table-size 2)
				 imported-bindings
				 exported-bindings)
    (set! *imported-bindings*
	  (if (vm-eq? imported-bindings false)
	      (make-hash-table key)
	      imported-bindings))
    (set! *exported-bindings*
	  (if (vm-eq? exported-bindings false)
	      (make-hash-table key)
	      exported-bindings))))

(define shared-binding-table-size
  (* hash-table-size 2))

(add-gc-root!
  (lambda ()
    (set! *imported-bindings* (s48-trace-value *imported-bindings*))
    (set! *exported-bindings* (s48-trace-value *exported-bindings*))))

; These next two procedure are used to write the bindings tables out in images.

(define (s48-exported-bindings)
  *exported-bindings*)

; This returns a version of the import table that contains only those bindings
; that have been traced, and in which the values of the bindings are all set to
; UNASSIGNED-VALUE.

(define s48-cleaned-imported-bindings
  (let ((cleaner (table-cleaner shared-binding-next set-shared-binding-next!))
	(walker (table-walker shared-binding-next)))
    (lambda ()
      (let ((table (s48-trace-value *imported-bindings*)))
	(cleaner table)
	(walker (lambda (binding)
		  (shared-binding-set! binding unassigned-marker))
		table)
	table))))

; Imported bindings.

(define lookup-imported-binding
  (let* ((maker (lambda (string next key)
		  (make-shared-binding string true unspecific-value next key)))
	 (lookup (table-searcher shared-binding-name
				 shared-binding-next
				 maker)))
    (lambda (name key)
      (lookup *imported-bindings* name key))))
    
; Exporting bindings.

(define lookup-exported-binding
  (let* ((maker (lambda (string next key)
		  (make-shared-binding string false unspecific-value next key)))
	 (lookup (table-searcher shared-binding-name
				 shared-binding-next
				 maker)))
    (lambda (name key)
      (lookup *exported-bindings* name key))))

; Print warnings about all imported bindings which the external code
; has not yet defined.

(define s48-warn-about-undefined-imported-bindings
  (let ((walker (table-walker shared-binding-next)))
    (lambda ()
      (let ((out (current-error-port)))
	(walker (lambda (binding)
		  (if (undefined? (shared-binding-ref binding))
		      (let ((name (shared-binding-name binding)))
			(write-string "undefined imported name " out)
			(if (vm-string? name)
			    (write-string (extract-string name) out)
			    (write-string "<invalid name>" out))
			(write-char #\newline out))))
		*imported-bindings*)))))

;----------------
; Four primitives for adding and removing imports and exports.

(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 undefine-shared-binding!
  (table-remover shared-binding-name
		 shared-binding-next
		 set-shared-binding-next!))

(define-primitive undefine-shared-binding (string-> boolean->)
  (lambda (name is-import?)
    (undefine-shared-binding! (if is-import?
				  *imported-bindings*
				  *exported-bindings*)
			      name)
    (goto continue 0)))

;----------------
; The following two functions are exported to C, hence the reversal of the
; export/import terminology.

(define (s48-define-exported-binding name value)
  (receive (key value)
      (ensure-space-saving-temp (+ shared-binding-size
				   (vm-string-size (string-length name)))
				value)
    (shared-binding-set! (lookup-imported-binding (enter-string name key) key)
			 value)))

(define (s48-get-imported-binding name)
  (let ((key (ensure-space (+ shared-binding-size
			      (vm-string-size (string-length name))))))
    (lookup-exported-binding (enter-string name key) key)))