Commit d176c74c authored by Erick Gallesio's avatar Erick Gallesio

Added a way to partially import a module

parent de4911fd
......@@ -2,17 +2,10 @@
#
# Author: Erick Gallesio [eg@unice.fr]
# Creation date: 20-Dec-2006 10:09 (eg)
# Last file update: 28-Feb-2007 22:58 (eg)
# Last file update: 12-Apr-2007 18:34 (eg)
SRCS = scmpkg-define.stk \
scmpkg-exception.stk \
scmpkg-interface.stk \
scmpkg-languages.stk \
scmpkg-parameter.stk \
scmpkg-record.stk \
scmpkg-runtime.stk
OBJ = scmpkg-support.ostk
SRCS = scmpkg-interface.stk scmpkg-languages.stk
OBJ = scmpkg-support.ostk
......
......@@ -18,7 +18,7 @@
#
# Author: Erick Gallesio [eg@unice.fr]
# Creation date: 20-Dec-2006 10:09 (eg)
# Last file update: 28-Feb-2007 22:58 (eg)
# Last file update: 12-Apr-2007 18:34 (eg)
VPATH = @srcdir@
pkgdatadir = $(datadir)/@PACKAGE@
......@@ -185,14 +185,7 @@ sysconfdir = @sysconfdir@
target_alias = @target_alias@
top_builddir = @top_builddir@
top_srcdir = @top_srcdir@
SRCS = scmpkg-define.stk \
scmpkg-exception.stk \
scmpkg-interface.stk \
scmpkg-languages.stk \
scmpkg-parameter.stk \
scmpkg-record.stk \
scmpkg-runtime.stk
SRCS = scmpkg-interface.stk scmpkg-languages.stk
OBJ = scmpkg-support.ostk
scheme_libdir = $(prefix)/share/@PACKAGE@/@VERSION@
scheme_lib_DATA = scmpkg-support.stk $(OBJ)
......
;;;;
;;;; scmpkg-define.stk -- ScmPkg 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: 28-Feb-2007 22:00 (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))
((?var ?value)
`(define ,var ,value))
(else
(error '@define "bad form ~S" body))))
;; ----------------------------------------------------------------------
;; define*
;; ----------------------------------------------------------------------
(define-macro (define* . body)
`(@define ,@body))
;;;
;;; export %srfi89->ext-lambda-proto
;;;
(export %srfi89->ext-lambda-proto)
;;;;
;;;; scmpkg-exception.stk -- ScmPkg 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: 28-Feb-2007 22:32 (eg)
;;;;
(define (%map-scmpkg-exception-on-condition name)
(case name
((@exception) '&@exception)
((@error) '&@error)
((@io-error) '&@io-error)
((@type-error) '&@type-error)
((@not-implemented-error) '&@not-implemented-error)
(else name)))
;; ======================================================================
;; 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
,parent
',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 '&@exception)
(body body)
(fields '()))
(cond
((pair? name)
(case (length name)
((1) (Loop (car name) '&@exception body fields))
((2) (Loop (car name) (%map-scmpkg-exception-on-condition (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)
(define (valid-keyword? key)
(or (keyword? key) (memq key '(?proc ?reason ?obj))))
(let Loop ((args args)
(proc #f)
(reason #f)
(obj #f)
(other '()))
(if (null? args)
(let ((name (%map-scmpkg-exception-on-condition name)))
`(make-condition ,name
'backtrace '()
'location ',(or proc name)
'message (string-append (or ,reason "")
(if ,obj (format " ~s" ,obj) ""))
,@other))
(let ((key (car args)))
(if (and (valid-keyword? key) (not (null? (cdr args))))
(case key
((?proc) (Loop (cddr args) (cadr args) reason obj other))
((?reason) (Loop (cddr args) proc (cadr args) obj other))
((?obj) (Loop (cddr args) proc reason (cadr args) other))
(else (Loop (cddr args) proc reason obj
(append!
other
`(',(string->symbol (keyword->string (car args)))
,(cadr args))))))
(error "bad keyword ~S" (car args)))))))
;; ======================================================================
(export %map-scmpkg-exception-on-condition)
\ No newline at end of file
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 11-Dec-2006 14:39 (eg)
;;;; Last file update: 9-Apr-2007 19:30 (eg)
;;;; Last file update: 12-Apr-2007 21:24 (eg)
;;;;
......@@ -78,44 +78,44 @@
(map (lambda (x) (string->symbol (format "@~a-~a" main x)))
(cdr lang)))
imp))))
(define (partial-import module symbols)
;; Generate code for importing only some symbols of a module
(unless (and (symbol? module)
(list? symbols)
(every symbol? symbols))
(error 'interface "bad import ~S" (cons module symbols)))
`(let ((module (find-module ',module)))
,@(map (lambda(x)`(%symbol-alias ',x ',x module)) symbols)))
(let* ((pi (in-module |ScmPkg| parse-interface))
(pkg (pi name body))
(exp (scmpkg-package-exports pkg))
(imp (find-imports
(scmpkg-package-language pkg)
(scmpkg-package-imports pkg))))
(eprintf ")==> ~S\n" imp)
`(begin
;; Require scmpkg-support
(require "scmpkg-support")
;; Require all the imported modules
,@(map (lambda (x) `(require-for-syntax ,(symbol->string x)))
,@(map (lambda (x)
`(require-for-syntax ,(symbol->string (if (pair? x) (car x) x))))
imp)
,@(map (lambda (x) `(require ,(symbol->string x)))
,@(map (lambda (x) `(require ,(symbol->string (if (pair? x) (car x) x))))
imp)
;; Define a module for the scmpkg package
(define-module ,name
;; Imports
(import ,@imp)
,@(map (lambda (x)
(if (pair? x)
(partial-import (car x) (cdr x))
`(import ,x)))
imp)
;; Exports
(export ,@exp)
;;// ;; Define all the macros
;;// ,@(map (lambda (x)
;;// (eprintf "Definition de la macro ~S\n" x)
;;// `(define-macro ,@x))
;;// (reverse (scmpkg-package-macros pkg)))
;;// ;; Syntaxes
;;// ,@(map (lambda (x)
;;// (eprintf "Syntax definition ~S\n" x))
;;// (reverse (scmpkg-package-syntaxes pkg)))
;;// ;; Exceptions
;;// ,@(map (lambda (x)
;;// `(define-scmpkg-exception ,@x))
;;// (reverse (scmpkg-package-exceptions pkg)))
;;// ;; Records
;;// ,@(map (lambda (x)
;;// `(define-exported-record ,(car x) ,@(cdr x)))
;;// (reverse (scmpkg-package-records pkg)))
;; Body
(include ,(scmpkg-package-source pkg)))
;; Provide
......
;;;;
;;;; parameter.stk -- ScmPkg 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))))
;;;;
;;;; scmpkg-record.stk -- ScmPkg record support
;;;;
;;;; 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: 21-Dec-2006 12:00 (eg)
;;;; Last file update: 28-Feb-2007 22:05 (eg)
;;;;
(define (%define-scmpkg-record->struct name parent slots exported?)
(let ((pred (string->symbol (format "~a?" name)))
(constr (string->symbol (format "make-~a" name)))
(arg (gensym))
(val (gensym)))
`(begin
;; Build the structure
(define ,name (make-struct-type ',name ,parent ',(map car slots)))
;; Build the constructor
(define (,constr . ,arg)
(apply make-struct ,name ,arg))
;; Build the predicate
(define (,pred ,arg)
(and (struct? ,arg) (struct-is-a? ,arg ,name)))
;; Build the slot readers
,@(map (lambda (x)
`(define ,(cadr x)
(lambda (,arg)
(%fast-struct-ref ,arg ,name ',(cadr x) ,(cadddr x)))))
slots)
;; Build the slot setters
,@(map (lambda (x)
`(define ,(caddr x)
(lambda (,arg ,val)
(%fast-struct-set! ,arg ,name ',(caddr x) ,(cadddr x) ,val))))
slots)
,(if exported?
`(export ,name ,constr ,pred
,@(map cadr slots)
,@(map caddr slots))
'(void))
;; Build the toplevel result
(values (void) ',name))))
(define (%define-scmpkg-record name body exported?)
(let Loop ((body body)
(parent #f)
(fields '())
(offset 0))
(cond
((null? body)
(%define-scmpkg-record->struct name parent (reverse! fields) exported?))
((not (pair? body))
(error "bad record ~S" body))
((keyword? (car body))
(cond
((null? (cdr body))
(error "value expected after keyword ~S" (car body)))
((eq? (car body) parent:)
(Loop (cddr body) (cadr body) fields offset))
(else ;; ignore this keyword for STklos
(Loop (cddr body) parent fields offset))))
(else
(match-case (car body)
((? symbol?)
(let ((fld (car body)))
(Loop (cdr body)
parent
(cons (list fld
(string->symbol (format "~a-~a" name fld))
(string->symbol (format "~a-~a-set!" name fld))
offset)
fields)
(+ offset 1))))
(((? symbol?) (? symbol?) (? symbol?))
(let ((fld (caar body))
(getter (cadar body))
(setter (cadar body)))
(Loop (cdr body)
parent
(cons (list fld getter setter offset) fields)
(+ offset 1))))
(else
(error "bad record field ~S" (car body))))))))
;; ======================================================================
;; define-record ...
;; ======================================================================
(define-macro (define-record name . body)
(%define-scmpkg-record name body #f))
;; ======================================================================
;; %define-exported-record ...
;; ======================================================================
(define-macro (define-exported-record name . body)
(%define-scmpkg-record name body #t))
;;
;; Exports
;;
(export %define-scmpkg-record %define-scmpkg-record->struct)
(provide "scmpkg-record")
;;;;
;;;; scmpkg-runtime.stk -- ScmPkg runtime for STklos
;;;;
;;;; 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: 12-Feb-2007 18:51 (eg)
;;;; Last file update: 28-Feb-2007 22:05 (eg)
;;;;
;; ======================================================================
;; record ...
;; ======================================================================
;; ======================================================================
;; exception ...
;; ======================================================================
;;;;
;;;; definition of condition types for ScmPkg
;;;;
(define &scmpkg-cond (make-condition-type '&scmpkg-cond
&condition
'(location message backtrace)))
(define &@exception
(make-compound-condition-type '@exception
(list &condition &scmpkg-cond)))
(define &@error ;; &error-message)
(make-compound-condition-type '@error
(list &error-message &scmpkg-cond)))
(define &@io-error
(make-compound-condition-type '@io-error
(list &i/o-error &scmpkg-cond)))
(define &@type-error
(make-compound-condition-type '@type-error
(list &error-message &scmpkg-cond)))
(define &@not-implemented-error
(make-compound-condition-type '@not-implemented-error
(list &condition &scmpkg-cond)))
;;;;
;;;; @RAISE and @ERROR
;;;;
(define @raise raise)
(define (@error proc reason obj)
; (&raise (exception @error ?proc proc ?reason reason ?obj obj))
(error proc reason obj))
(define (@exception-message e)
(if (and (condition? e)
(condition-has-type? e &scmpkg-cond))
(condition-ref e 'message)
(error "cannot find a message associated to exception ~S" e)))
;; ======================================================================
;; File System Primitives ...
;; ======================================================================
(define (@directory-list dir)
(delete! "."
(delete! ".."
(directory-files dir))))
(define (@file-exists? filename)
(or (file-exists? filename)
(file-is-directory? filename)))
(define @file-directory? file-is-directory?)
(define @delete-file remove-file)
(define @rename-file rename-file)
(define (@create-directory dir)
(if (string? dir)
(with-handler (lambda (c) #f)
(make-directory dir)
#t)
(error "bad string ~S" dir)))
(define (@delete-directory dir)
(if (string? dir)
(with-handler (lambda (c) #f)
(remove-directory dir)
#t)
(error "bad string ~S" dir)))
;; ======================================================================
;; Host OS ...
;; ======================================================================
(define @exit exit)
(define @command-line (lambda () (cons (program-name) (argv))))
(define @getenv getenv)
(define @system system)
;; ======================================================================
;; Bit Operation ...
;; ======================================================================
(define @fxand bit-and)
(define @fxior bit-or)
(define @fxxor bit-xor)
(define @fxnot bit-not)
(define @fxarithmetic-shift-left bit-shift)
(define @fxarithmetic-shift-right bit-rshift)
;; ======================================================================
;; Misc ...
;; ======================================================================
(define @unspecified void)
(define @gensym gensym)
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 1-Jun-2000 12:26 (eg)
;;;; Last file update: 3-Apr-2007 20:34 (eg)
;;;; Last file update: 13-Apr-2007 11:00 (eg)
;;;;
......@@ -200,22 +200,38 @@ doc>
* (define b 'M1-b))
*
* (define-module M2
* (export b c)
* (export b c d)
* (define b 'M2-b)
* (define c 'M2-c))
* (define c 'M2-c)
* (define d 'M2-d))
*
* (define-module M3
* (import M1 M2)
* (display (list a b c))) @print{} (m1-a m1-b m2-c)
* (display (list a b c d))) @print{} (M1-a M1-b M2-c M2-d)
* @end lisp
*
* (define-module M4
* (import M2 M1)
* (display (list a b c d))) @print{} (M1-a M2-b M2-c M2-d)
* @end lisp
*
* It is also possible to import partially (i.e. not all
* exported symbols) from a module, as shown below:
* @lisp
* (define-module M5
* (import (M2 c d) M1)
* (display (list a b c d))) @print{} (M1-a M1-b M2-c M2-d)
* @end lisp
* In this case, only the symbols |c| and |d| are imported from
* module |M2|.
*
* ,(bold "Note:") Importations are not ,(emph "transitive"): when
* the module ,(emph "C") imports the module ,(emph "B") which is an importer
* of module ,(emph "A") the symbols of ,(emph "A") are not visible
* from ,(emph "C"), except by explicitly importing the ,(emph "A")
* module from ,(emph "C").
*
* ,(bold "Note:") The module |STklos|, which contains the ,(emph "global
* ,(bold "Note:") The module |STklos|, which contains the ,(emph "global
* variables") is always implicitly imported from a module. Furthermore,
* this module is always placed at the end of the list of imported modules.
doc>
......@@ -234,15 +250,70 @@ doc>
(cons mod res))) ; add it to our result
(error 'import "module `~S' does not exist" (car l)))))))
(define (%module-aliases module-name symbols)
;; define aliases in the current module of symbols from module-name
(let ((module (find-module module-name #f)))
(unless module
(error 'import "cannot find module ~S" module-name))
(let ((exports (module-exports module)))
(for-each (lambda (x)
(if (memq x exports)
(%symbol-alias x x module)
(error 'import "symbol ~S is not exported from module ~S"
x module-name)))
symbols))))
;;(define-macro (import . modules)
;; (if (null? modules)
;; '()
;; `(%module-import (current-module) ',modules)))
(define-macro (import . modules)
(define (split-modules lst)
(let loop ((lst modules)
(full '())
(part '()))
(cond
((null? lst)
(values (reverse! full) (reverse! part)))
((symbol? (car lst))
;; full import
(loop (cdr lst)
(cons (car lst) full)
part))
((and (pair? (car lst)) (symbol? (caar lst)) (null? (cdar lst)))
;; a list which contains only a symbol. This is a full import
(loop (cdr lst)