File: const.sc

package info (click to toggle)
scheme2c 2011.07.26-5
  • links: PTS, VCS
  • area: main
  • in suites: wheezy
  • size: 4,760 kB
  • sloc: ansic: 62,439; lisp: 15,686; asm: 851; makefile: 673; sh: 19; csh: 9
file content (95 lines) | stat: -rw-r--r-- 3,359 bytes parent folder | download | duplicates (3)
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))))