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
|
;;; C declaration compiler.
;* Copyright (c) 1989-1993 Hewlett-Packard Development Company, L.P.
;* All Rights Reserved
;* Permission is hereby granted, free of charge, to any person obtaining a
;* copy of this software and associated documentation files (the "Software"),
;* to deal in the Software without restriction, including without limitation
;* the rights to use, copy, modify, merge, publish, distribute, sublicense,
;* and/or sell copies of the Software, and to permit persons to whom the
;* Software is furnished to do so, subject to the following conditions:
;*
;* The above copyright notice and this permission notice shall be included in
;* all copies or substantial portions of the Software.
;*
;* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;* DEALINGS IN THE 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))))
|