;;; C declaration compiler.

;*              Copyright 1989 Digital Equipment Corporation
;*                         All Rights Reserved
;*
;* Permission to use, copy, and modify this software and its documentation is
;* hereby granted only under the following terms and conditions.  Both the
;* above copyright notice and this permission notice must appear in all copies
;* of the software, derivative works or modified versions, and any portions
;* thereof, and both notices must appear in supporting documentation.
;*
;* Users of this software agree to the terms and conditions set forth herein,
;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
;* right and license under any changes, enhancements or extensions made to the
;* core functions of the software, including but not limited to those affording
;* compatibility with other hardware or software environments, but excluding
;* applications which incorporate this software.  Users further agree to use
;* their best efforts to return to Digital any such changes, enhancements or
;* extensions that they make and inform Digital of noteworthy uses of this
;* software.  Correspondence should be provided to Digital at:
;* 
;*                       Director of Licensing
;*                       Western Research Laboratory
;*                       Digital Equipment Corporation
;*                       100 Hamilton Avenue
;*                       Palo Alto, California  94301  
;* 
;* This software may be distributed (but not offered for sale or transferred
;* for compensation) to third parties, provided such third parties agree to
;* abide by the terms and conditions of this notice.  
;* 
;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
;* SOFTWARE.

;;; This module compiles constant expressions.
;;;
;;;	(const <identifier> <expression>)
;;;
;;; which defines a constant.  The expression is evaluated at compile time
;;; and is defined as the following:
;;;
;;;	<expression> ::= <constant-symbol>
;;;		         Scheme-constant
;;;		         ( Scheme-procedure [ <expression> ... ] )
;;;
;;; When stubs are being generated, this will result in:
;;;
;;;	(define <identifier> <value>)
;;;
;;; and when an include file is being generated, it will generate:
;;;
;;;	(define-constant <identifier> <value>)

(module const)

;;; During the input phase, the following function is called to process
;;; constant expressions.  It will return either the constant or call error
;;; on an error.

(define (INPUT-CONST exp)
    (if (and (= (length exp) 3) (symbol? (cadr exp)))
	(let ((id (cadr exp)))
	     (putprop id 'const (cddr exp))
	     id)
	(error 'input-const "Illegal syntax: ~s" exp)))

;;; A constant value is computed by the following expression.  Any errors will
;;; be reported by calling error.

(define (CONST-VALUE const)
    (cond ((symbol? const)
	   (let ((value (getprop const 'const)))
		(if value
		    (const-value (car value))
		    (error 'const-value "Undefined constant: ~s"
			   const))))
	  ((pair? const)
	   (let ((proc (top-level-value (car const))))
		(if (procedure? proc)
		    (apply proc (map const-value (cdr const)))
		    (error 'const-value "Undefined function: ~s"
			   (car const)))))
	  (else const)))

;;; Stub declarations are generated by the following function.

(define (EMIT-CONSTS constants define-only const-file-root)
    (with-output-to-file
	(string-append const-file-root ".sc")
	(lambda ()
		(format #t "(module ~a)~%~%" const-file-root)
		(for-each
		    (lambda (const)
			    (unless (memq const define-only)
				    (format #t "(define ~s ~s)~%"
					    const (const-value const))))
		    constants)))
    (with-output-to-file
	(string-append const-file-root ".sch")
	(lambda ()
		(for-each
		    (lambda (const)
			    (unless (memq const define-only)
				    (format #t "(define-constant ~s ~s)~%"
					    const (const-value const))))
		    constants))))