Commit 571440bd authored by Erick Gallesio's avatar Erick Gallesio

Introducing Split packages

parent 80dceec5
# Makefile.am for STklos lib
#
# Author: Erick Gallesio [eg@unice.fr]
# Creation date: 20-Dec-2006 10:09 (eg)
# Last file update: 7-Feb-2007 17:50 (eg)
scheme_splitdir = $(prefix)/share/@PACKAGE@/@VERSION@/Split.d
scheme_split_DATA = split-exception.stk \
split-interface.stk \
split-languages.stk
This diff is collapsed.
;;;;
;;;; split-define.stk -- Split define* form
;;;;
;;;; Copyright 2007 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 9-Feb-2007 15:11 (eg)
;;;; Last file update: 9-Feb-2007 15:24 (eg)
;;;;
;; ----------------------------------------------------------------------
;; %srfi89->ext-lambda-proto ...
;; ----------------------------------------------------------------------
(define (%srfi89->ext-lambda-proto args)
;; Code derivated from Bigloo srfi89 support for packages
;; Code given by Manuel Serrano
(define (srfi89-positional? a)
(match-case a
(((? symbol?) ?-) #t)
(else #f)))
(define (srfi89-named? a)
(match-case a
(((? keyword?) (? symbol?) ?-) #t)
(else #f)))
(define (srfi89-named->dsssl-named arg)
(match-case arg
((?key ?- ?val)
(list (string->symbol (keyword->string key)) val))))
(if (not (pair? args))
args
(let loop ((a args)
(reqs '())
(optionals '())
(names '()))
(cond
((symbol? a)
(if (or (pair? optionals) (pair? names))
(error "not implemented yet ~S" args)
args))
((null? a)
(if (and (null? optionals) (null? names))
args
(let ((opts (if (pair? optionals)
(cons '#!optional (reverse! optionals))
'()))
(names (if (pair? names)
(cons '#!key names)
'())))
(append (reverse! reqs) opts names))))
((not (pair? a))
(error "illegal argument ~S" a))
(else
(let ((a0 (car a)))
(cond
((symbol? a0)
(loop (cdr a) (cons a0 reqs) optionals names))
((srfi89-positional? a0)
(loop (cdr a) reqs (cons a0 optionals) names))
((srfi89-named? a0)
(let ((d (srfi89-named->dsssl-named a0)))
(loop (cdr a) reqs optionals (cons d names))))
(else
(error "illegal argument ~S" a)))))))))
;; ----------------------------------------------------------------------
;; define*
;; ----------------------------------------------------------------------
(define-macro (define* . body)
(match-case body
(((?var . ?args) . ?rest)
`(define (,var . ,(%srfi89->ext-lambda-proto args)) ,@rest))
(else
(error 'define* "bad form ~S" body))))
;;;
;;; export %srfi89->ext-lambda-proto
;;;
(export %srfi89->ext-lambda-proto)
;;;;
;;;; split-exception.stk -- Split exception implementation
;;;;
;;;; Copyright © 2006-2007 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 15-Dec-2006 15:15 (eg)
;;;; Last file update: 9-Feb-2007 14:33 (eg)
;;;;
;; ======================================================================
;; define-exception
;; ======================================================================
(define-macro (define-scmpkg-exception name . body)
(define (%define-exception->condition name parent slots)
(let ((pred (string->symbol (format "~a?" name)))
(constr (string->symbol (format "make-~a" name)))
(arg (gensym))
(val (gensym)))
`(begin
;; Build the condition
(define ,name (make-condition-type ',name
,(if parent parent '&condition)
',slots))
;; Build the predicate
(define (,pred ,arg)
(and (condition? ,arg) (condition-has-type? ,arg ,name)))
;; Export name constructor and predicate
(export ,name ,constr ,pred)
;; Build the readers and setters
(let ((module (current-module)))
(for-each (lambda (x)
(let ((reader (string->symbol (format "~a-~a" ',name x)))
(writer (string->symbol (format "~a-~a-set!"
',name x))))
;; reader
(%symbol-define reader
(lambda(,arg)
(condition-ref ,arg x x))
module)
;; writer
(%symbol-define writer
(lambda (,arg ,val)
(condition-set! ,arg x ,val))
module)
;; export reader and writer
(%module-export module (list reader writer))))
(struct-type-slots ,name)))
;; Build the toplevel result
(values (void) ',name))))
;;
;; body of define-exception*
;;
(let Loop ((name name)
(parent #f)
(body body)
(fields '()))
(cond
((pair? name)
(case (length name)
((1) (Loop (car name) #f body fields))
((2) (Loop (car name) (cadr name) body fields))
(else (error "bad exception name ~S" name))))
((null? body)
(%define-exception->condition name parent (reverse! fields)))
((symbol? (car body))
(Loop name
parent
(cdr body)
(cons (car body) fields)))
(else
(error "bad exception field expected ~S" (car body))))))
;; ======================================================================
;; exception
;; ======================================================================
(define-macro (exception name . args)
(let Loop ((args args)
(res '()))
(cond
((null? args)
`(make-condition ,name ,@res))
((and (pair? args)
(keyword? (car args))
(not (null? (cdr args)))
(Loop (cddr args)
(append! res
`(',(string->symbol (keyword->string (car args)))
,(cadr args))))))
(else (error "bad parameter ~S" args)))))
;;;;
;;;; split-interface.stk -- Split interfaces in STklos
;;;;
;;;; Copyright 2006-2007 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 11-Dec-2006 14:39 (eg)
;;;; Last file update: 9-Feb-2007 14:31 (eg)
;;;;
(define-struct split-package
name
version
language
source
suffix
imports
exports
macros
syntaxes
exceptions)
(define (%new-split-package name)
(make-split-package name ; name
'v0.0.0 ; version
'scheme ; language
#f ; source
#f ; suffix
'() ; imports
'() ; exports
'() ; macros
'() ; syntaxes
'() ; exceptions
))
(define-macro (%push! lst v)
`(set! ,lst (cons ,v ,lst)))
;; ======================================================================
;; interface ...
;; ======================================================================
(define-macro (interface name . body)
(let* ((pkg (parse-interface name body))
(imp (split-package-imports pkg))
(exp (split-package-exports pkg)))
`(begin
;; Require all the imported modules
,@(map (lambda (x) (list 'require (symbol->string x))) imp)
;; Define a module for the split package
(define-module ,name
;; Imports
(import ,@(split-package-imports pkg))
;; Exports
(export ,@(split-package-exports pkg))
;; Define all the macros
,@(map (lambda (x)
(eprintf "Definition de la macro ~S\n" x)
`(define-macro ,@x))
(reverse (split-package-macros pkg)))
;; Syntaxes
,@(map (lambda (x)
(eprintf "Syntax definition ~S\n" x))
(reverse (split-package-syntaxes pkg)))
;; Exceptions
,@(map (lambda (x)
`(define-scmpkg-exception ,@x))
(reverse (split-package-exceptions pkg)))
;; Body
(include ,(split-package-source pkg)))
;; Provide
(provide ,(symbol->string name)))))
;; ======================================================================
;; parse-interface ...
;; ======================================================================
(define (parse-interface name body)
(define (choose-language pkg lang)
(let ((info (assoc lang *split-languages*)))
(unless info
(error 'interface "Language ~S is not managed" lang))
;; Set the language
(set! (split-package-language pkg) lang)
;; Set the default suffix
(unless (split-package-suffix pkg)
(set! (split-package-suffix pkg) (key-get (cdr info) :suffix)))))
(define (patch-package-export-list! pkg)
(let ((exports '()))
(for-each
(lambda (x)
(if (symbol? x)
(%push! exports x) ;; export a variable
(match-case x
((macro . ?rest) ;; export a macro
(%push! (split-package-macros pkg) rest))
((syntax ?args . ?-) ;; export a syntax
(%push! (split-package-syntaxes pkg) args))
((exception . ?rest) ;; export an exception
(%push! (split-package-exceptions pkg) rest))
(else
(%push! exports (car x))))))
(split-package-exports pkg))
(set! (split-package-exports pkg) exports)))
(define (patch-package! pkg)
;; Language & suffix
(choose-language pkg (split-package-language pkg))
;; Source
(unless (split-package-source pkg)
(set! (split-package-source pkg)
(format "~a.~a" name (split-package-suffix pkg))))
;; Arrange the export list
(patch-package-export-list! pkg)
;; Return the updated package
pkg)
(let ((pkg (%new-split-package name)))
(for-each (lambda (clause)
(match-case clause
((version ?version)
(set! (split-package-version pkg) version))
((language ?lg)
(set! (split-package-language pkg) lg))
((source ?src)
(set! (split-package-source pkg) src))
((suffix ?sfx)
(set! (split-package-suffix pkg) sfx))
((import . ?imp)
(set! (split-package-imports pkg) imp))
((export . ?exp)
(set! (split-package-exports pkg) exp))
(else
(error 'interface "Invalid clause ~S" clause))))
body)
(patch-package! pkg)))
;;;;
;;;; split-languages.stk -- Split Languages support
;;;;
;;;; Copyright © 2007 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 7-Feb-2007 13:39 (eg)
;;;; Last file update: 7-Feb-2007 16:26 (eg)
;;;;
(define *split-languages*
'(
;; STklos
(stklos :suffix "stk")
;; Bigloo
(bigloo :suffix "scm")
;; Scheme (the default)
(scheme :suffix "scm")))
;;;;
;;;; parameter.stk -- Split parameters
;;;;
;;;; Copyright © 2007 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 5-Feb-2007 22:10 (eg)
;;;; Last file update: 5-Feb-2007 22:12 (eg)
;;;;
(define-macro (define-parameter p value :optional setter)
(let ((val (gensym))
(set (string->symbol (format "~a-set!" p))))
`(begin
,(if setter
`(define ,p (make-parameter ,value ,setter))
`(define ,p (make-parameter ,value)))
(define (,set ,val)
(,p ,val))
(values (void) ',p))))
;;;;
;;;; split-support.stk -- SPLIT support
;;;;
;;;; Copyright © 2007 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 7-Feb-2007 11:03 (eg)
;;;; Last file update: 9-Feb-2007 15:23 (eg)
;;;;
;; ======================================================================
;; The SPLIT STklos module
;; ======================================================================
(define-module |SPLIT|
(include "Split.d/split-languages.stk")
(include "Split.d/split-interface.stk")
(include "Split.d/split-exception.stk")
(include "Split.d/split-parameter.stk")
(include "Split.d/split-define.stk")
; (include "Snow.d/snow-srfi89.stk")
; (include "Snow.d/snow-record.stk")
; (include "Snow.d/snow-package.stk")
; (include "Snow.d/snow-misc.stk")
)
;; ======================================================================
;; Split Runtime
;; ======================================================================
(define-condition-type @exception &message @exception?)
(define-condition-type @error &error-message @error?)
(define-condition-type @io-error &i/o-error @io-error?)
(define-condition-type @type-error &error-message @type-error?)
(define (exception-get-message cond)
(if (condition? cond)
(if (condition-has-type? cond &message)
(condition-ref cond 'message)
(format "condition of type ~S raised" (struct-type-name (struct-type cond))))
(error "bad exception ~S" cond)))
(%redefine-module-exports (find-module '|SPLIT|))
(provide "split-support")
......@@ -2,7 +2,7 @@
*
* e r r o r . c -- The error procedure
*
* Copyright © 1993-2000 ESSIrick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
* Copyright © 1993-2007 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
*
*
* This program is free software; you can redistribute it and/or modify
......@@ -22,7 +22,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 14-Nov-1993 14:58
* Last file update: 25-Apr-2006 18:48 (eg)
* Last file update: 8-Feb-2007 18:47 (eg)
*/
#include "stklos.h"
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment