source: project/release/3/crunch/trunk/crunch.scm @ 9918

Last change on this file since 9918 was 9918, checked in by Kon Lovett, 12 years ago

Using canonical directory structure.

File size: 3.1 KB
Line 
1;;;; crunch.scm
2;
3; Copyright (c) 2007, Felix L. Winkelmann
4; All rights reserved.
5;
6; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
7; conditions are met:
8;
9;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
10;     disclaimer.
11;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
12;     disclaimer in the documentation and/or other materials provided with the distribution.
13;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
14;     products derived from this software without specific prior written permission.
15;
16; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
17; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
18; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
19; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
20; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
21; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
22; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
23; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
24; POSSIBILITY OF SUCH DAMAGE.
25;
26; Send bugs, suggestions and ideas to:
27;
28; felix@call-with-current-continuation.org
29;
30; Felix L. Winkelmann
31; Unter den Gleichen 1
32; 37130 Gleichen
33; Germany
34
35
36(require 'crunch-compiler)
37
38(cond-expand
39 (disable-crunch
40  (define-macro (crunch . body) `(begin ,@body)) )
41 (else
42  (define-macro (crunch . body)
43    (let ((out (open-output-string)))
44      (let-values (((f exports) (crunch-compile `(begin ,@body) out)))
45        `(begin
46           ,@(map crunch-export->foreign-lambda exports)
47           (foreign-declare ,(get-output-string out))
48           (foreign-code ,(conc f "();")) ) ) ) ) ) )
49
50(define-macro (define-crunch-primitives . prims)
51  (for-each
52   (lambda (p)
53     (unless (and (list? p) (list? (car p)) 
54                  (memq (cadr p) '(-> +>))
55                  (>= 3 (length p)) (symbol? (caar p)))
56       (syntax-error 
57        'define-crunch-primitives
58        "invalid primitive specification" p) )
59     (let* ((arg (and (pair? (cdddr p)) (cadddr p)))
60            (real-name (if (string? arg)
61                           arg
62                           (symbol->string (caar p))) ))
63       (crunch-register-primitive
64        (caar p) (cdar p) (caddr p)
65        real-name #f 
66        (and (pair? (car p) (eq? '+> (cadr p)))))))
67   prims)
68  '(void) )
69
70(define-macro (define-crunch-callback head . body)
71  (unless (and (pair? head) (symbol? (car head)))
72    (syntax-error 'define-crunch-callback "invalid callback definition" head) )
73  (let ((name (gensym 'crunch_callback)))
74    (crunch-register-primitive
75     (car head)
76     (map (lambda (a) (crunch-foreign-type (car a))) (cdr head))
77     (crunch-foreign-type (car body))
78     name #t) 
79    `(define-external (,name ,@(cdr head)) ,@body) ) )
Note: See TracBrowser for help on using the repository browser.