aboutsummaryrefslogtreecommitdiff
path: root/src/bigloo/api.sch
diff options
context:
space:
mode:
authorLudovic Court`es2005-06-15 13:00:39 +0000
committerLudovic Court`es2005-06-15 13:00:39 +0000
commitfc42fe56a57eace2dbdb31574c2e161f0eacf839 (patch)
tree18111570156cb0e3df0d81c8d104517a2263fd2c /src/bigloo/api.sch
downloadskribilo-fc42fe56a57eace2dbdb31574c2e161f0eacf839.tar.gz
skribilo-fc42fe56a57eace2dbdb31574c2e161f0eacf839.tar.lz
skribilo-fc42fe56a57eace2dbdb31574c2e161f0eacf839.zip
Initial import of Skribe 1.2d.
Initial import of Skribe 1.2d. git-archimport-id: lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--base-0
Diffstat (limited to 'src/bigloo/api.sch')
-rw-r--r--src/bigloo/api.sch91
1 files changed, 91 insertions, 0 deletions
diff --git a/src/bigloo/api.sch b/src/bigloo/api.sch
new file mode 100644
index 0000000..390b8fa
--- /dev/null
+++ b/src/bigloo/api.sch
@@ -0,0 +1,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))))