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
|
;*=====================================================================*/
;* serrano/prgm/project/skribe/src/bigloo/api.sch */
;* ------------------------------------------------------------- */
;* Author : Manuel Serrano */
;* Creation : Mon Jul 21 18:15:25 2003 */
;* Last change : Wed Oct 27 12:43:23 2004 (eg) */
;* Copyright : 2003-04 Manuel Serrano */
;* ------------------------------------------------------------- */
;* The Bigloo macros for the API implementation */
;*=====================================================================*/
;*---------------------------------------------------------------------*/
;* define-pervasive-macro ... */
;*---------------------------------------------------------------------*/
(define-macro (define-pervasive-macro proto . body)
`(begin
(eval '(define-macro ,proto ,@body))
(define-macro ,proto ,@body)))
;*---------------------------------------------------------------------*/
;* define-markup ... */
;*---------------------------------------------------------------------*/
(define-pervasive-macro (define-markup proto . body)
(define (s2k symbol)
(string->keyword (string-append ":" (symbol->string symbol))))
(if (not (pair? proto))
(error 'define-markup "Illegal markup definition" proto)
(let* ((id (car proto))
(args (cdr proto))
(dargs (dsssl-formals->scheme-formals args error)))
`(begin
,(if (and (memq #!key args)
(memq '&skribe-eval-location args))
`(define-expander ,id
(lambda (x e)
(append
(cons ',id (map (lambda (x) (e x e)) (cdr x)))
(list :&skribe-eval-location
'(skribe-eval-location)))))
#unspecified)
(define ,(cons id dargs)
,(make-dsssl-function-prelude proto
args `(begin ,@body)
error s2k))))))
;*---------------------------------------------------------------------*/
;* define-simple-markup ... */
;*---------------------------------------------------------------------*/
(define-pervasive-macro (define-simple-markup markup)
`(define-markup (,markup #!rest opts #!key ident class loc)
(new markup
(markup ',markup)
(ident (or ident (symbol->string (gensym ',markup))))
(loc loc)
(class class)
(required-options '())
(options (the-options opts :ident :class :loc))
(body (the-body opts)))))
;*---------------------------------------------------------------------*/
;* define-simple-container ... */
;*---------------------------------------------------------------------*/
(define-pervasive-macro (define-simple-container markup)
`(define-markup (,markup #!rest opts #!key ident class loc)
(new container
(markup ',markup)
(ident (or ident (symbol->string (gensym ',markup))))
(loc loc)
(class class)
(required-options '())
(options (the-options opts :ident :class :loc))
(body (the-body opts)))))
;*---------------------------------------------------------------------*/
;* define-processor-markup ... */
;*---------------------------------------------------------------------*/
(define-pervasive-macro (define-processor-markup proc)
`(define-markup (,proc #!rest opts)
(new processor
(engine (find-engine ',proc))
(body (the-body opts))
(options (the-options opts)))))
;*---------------------------------------------------------------------*/
;* new (at runtime) */
;*---------------------------------------------------------------------*/
(eval '(define-macro (new id . inits)
(cons (symbol-append 'new- id)
(map (lambda (i)
(list 'list (list 'quote (car i)) (cadr i)))
inits))))
|
