summaryrefslogtreecommitdiff
path: root/legacy/bigloo/api.sch
diff options
context:
space:
mode:
authorLudovic Courtes2005-10-31 16:16:54 +0000
committerLudovic Courtes2005-10-31 16:16:54 +0000
commit89a424521b753ee7c2c67ebdc957865657f647c4 (patch)
tree7d15f69ef9aa87cd6e89153d34240baa031177c2 /legacy/bigloo/api.sch
parentfe831fd1e716de64a1b92beeabe4d865546dd986 (diff)
downloadskribilo-89a424521b753ee7c2c67ebdc957865657f647c4.tar.gz
skribilo-89a424521b753ee7c2c67ebdc957865657f647c4.tar.lz
skribilo-89a424521b753ee7c2c67ebdc957865657f647c4.zip
Moved the STkLos and Bigloo code to `legacy'.
Moved the STkLos and Bigloo code from `src' to `legacy'. git-archimport-id: lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2--patch-9
Diffstat (limited to 'legacy/bigloo/api.sch')
-rw-r--r--legacy/bigloo/api.sch91
1 files changed, 91 insertions, 0 deletions
diff --git a/legacy/bigloo/api.sch b/legacy/bigloo/api.sch
new file mode 100644
index 0000000..390b8fa
--- /dev/null
+++ b/legacy/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))))