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

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))))