scsh-0.6/scheme/big/external.scm

; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.

; Code for keeping external pointers in a table similar to the symbol table.
;
; The entry points for this code are:
;
; (GET-EXTERNAL string)    returns an external pointer
; (LOOKUP-ALL-EXTERNALS)   looks up new values for all external pointers;
;                          ideally this should be called automatically
;                          on startup
;
; (DYNAMIC-LOAD filename)  loads the file into the current image
;
; The following used to be in the PRIMITIVES interface when externals were
; a primitive data type.
;
; external?
; external-name
; external-value
; (external-lookup external)
; (call-external external . args)

; New, non-primitive data type.

(define-record-type external :external
  (make-external name value)
  external?
  (name external-name)
  (value external-value))

; Table of externals.

(define *the-external-table* #f)

(define (flush-the-external-table!)
  (set! *the-external-table* #f))

(define (restore-the-external-table!)
  (set! *the-external-table* (make-string-table))
  (vector-for-each (lambda (external)
		     (table-set! *the-external-table*
				 (external-name external)
				 external))
		   (find-all-records :external)))

(define (gc-externals)
  (flush-the-external-table!)
  (collect)
  (restore-the-external-table!))

(define (vector-for-each proc vector)
  (do ((i 0 (+ i 1)))
      ((>= i (vector-length vector))
       (unspecific))
    (proc (vector-ref vector i))))

(restore-the-external-table!)

;----------------
; Making new externals.

(define (get-external name)
  (cond ((table-ref *the-external-table* name)
	 => (lambda (x) x))
	(else
	 (let* ((value (make-code-vector 4 0))
		(new (make-external name value)))
	   (table-set! *the-external-table* name new)
	   (if (not (external-lookup name value))
	       (warn "External not found" name))
	   new))))

(import-lambda-definition external-lookup (name value) "s48_external_lookup")

; No longer necessary, as all strings now end with nulls.

(define (null-terminate str)
  str)

;----------------
; Re-lookup all externals.  This needs to be done whenever we resume an image.

(define (lookup-all-externals)
  (cond ((null? (really-lookup-all-externals))
	 #t)
	(else
	 (display "GCing to try to remove unbound externals")
	 (newline)
	 (gc-externals)
	 (let ((losers (really-lookup-all-externals)))
	   (if (null? losers)
	       #t
	       (let ((out (current-error-port)))
		 (display "Unbound external(s):" out)
		 (for-each (lambda (name)
			     (write-char #\space out)
			     (display name out))
			   losers)
		 #f))))))

; Re-lookup one external.

(define (lookup-external external)
  (external-lookup (external-name external)
		   (external-value external)))

; Quietly look up all externals, returning #F if unsuccessful

(define (try-to-lookup-all-externals)
  (null? (really-lookup-all-externals)))

; Look up all externals, returning a list of the names of those that cannot
; be found.

(define (really-lookup-all-externals)
  (let ((losers '()))
    (table-walk (lambda (name external)
		  (if (not (external-lookup name (external-value external)))
		      (set! losers (cons name losers))))
		*the-external-table*)
    losers))

;----------------

(define (call-external external . args)
  (apply call-external-value (external-value external)
	                     (external-name external)
			     args))

;----------------

(import-lambda-definition dynamic-load (filename) "s48_dynamic_load")