scmpkg-interface.stk 6.59 KB
Newer Older
1
;;;;
Erick Gallesio's avatar
Erick Gallesio committed
2
;;;; scmpkg-interface.stk	-- ScmPkg interfaces in STklos
3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23
;;;; 
;;;; 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)
Erick Gallesio's avatar
Erick Gallesio committed
24
;;;; Last file update:  1-Jun-2007 14:12 (eg)
25 26 27
;;;;


Erick Gallesio's avatar
Erick Gallesio committed
28
(define-struct scmpkg-package
29 30 31 32 33 34 35 36
  name
  version
  language
  source
  suffix
  imports
  exports
  macros
37
  syntaxes)
38

Erick Gallesio's avatar
Erick Gallesio committed
39 40 41
(define (%new-scmpkg-package name)
  (make-scmpkg-package name		; name
		       'v0.0.0		; version
Erick Gallesio's avatar
Erick Gallesio committed
42
		       '(r5rs)		; language
Erick Gallesio's avatar
Erick Gallesio committed
43 44 45 46 47 48 49
		       #f		; source
		       #f		; suffix
		       '()		; imports
		       '()		; exports
		       '()		; macros
		       '()		; syntaxes
		       ))
50 51 52 53


(define-macro (%push! lst v)
  `(set! ,lst (cons ,v ,lst)))
54 55 56


(define *ignored-interface-clauses*
57 58 59 60 61
  (append
      ;; meta-informations
      '(maintainer author description keywords license homepage snow)
      ;; Language specifics meta-informations
      (map car *scmpkg-languages*)))						 
62

63 64 65 66
;; ======================================================================
;;	interface ...
;; ======================================================================
(define-macro (interface name . body)
Erick Gallesio's avatar
Erick Gallesio committed
67 68

  (define (find-imports lang imp)
Erick Gallesio's avatar
Erick Gallesio committed
69 70 71
    (let ((main (car lang)))
      (if (member main '(r5rs stklos))
	  imp
Erick Gallesio's avatar
Erick Gallesio committed
72 73
	  (append! (cons (string->symbol (format "_~a" main))
			 (map (lambda (x) (string->symbol (format "_~a-~a" main x)))
Erick Gallesio's avatar
Erick Gallesio committed
74 75
			      (cdr lang)))
		   imp))))
76

77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110
  (define (merge-imports-exports imp exp)
    ;; When we have a "from" export clauses, add its package to imports
    (let ((add (filter-map (lambda(x)
			     (and (pair? x) (eq? (car x) 'from)
				  (if (= (length x) 2)
				      (cadr x)
				      (cdr x))))
			   exp)))
      (append imp add)))

  (define (do-exports lst)
    (let loop ((lst lst)
	       (symbs '())
	       (aliases '()))
      (cond
	((null? lst)
	 `(begin
	    (export ,@symbs)
	    ,@(map (lambda (x)
		     (if (null? (cdr x))
			 `(%module-aliases ',(car x)
					   (module-exports (find-module ',(car x)))
					   #t)
			 `(%module-aliases ',(car x) ',(cdr x) #t)))
		   aliases)))
	((symbol? (car lst))				; a symbol	
	 (loop (cdr lst)
	       (cons (car lst) symbs)
	       aliases))
	(else						; (from module ...)
	 (loop (cdr lst)
	       symbs
	       (cons (cdar lst) aliases))))))

111 112 113
  (define (publish-syntaxes lst)
    `(%%publish-syntax ,@lst))

114 115 116 117 118 119 120
  (let* ((pi     (in-module  |ScmPkg| parse-interface))
	 (pkg    (pi name body))
	 (imp    (scmpkg-package-imports pkg))
	 (exp    (reverse (scmpkg-package-exports pkg)))
	 (lang   (scmpkg-package-language pkg))
	 (req    (merge-imports-exports imp exp))
	 (allreq (find-imports lang req))
121 122 123
	 (allimp (find-imports lang imp))
	 (macs   (append (scmpkg-package-macros pkg)
			 (scmpkg-package-syntaxes pkg))))
124
    `(begin
Erick Gallesio's avatar
Erick Gallesio committed
125
       ;; Require scmpkg-support
126
       (require-library "scmpkg-support")
127
       ;; Require all the imported modules
128 129
       ,@(map (lambda (x)
		`(require-for-syntax ,(symbol->string (if (pair? x) (car x) x))))
130
	      allreq)
131
       ,@(map (lambda (x) `(require ,(symbol->string (if (pair? x) (car x) x))))
132
	      allreq)
Erick Gallesio's avatar
Erick Gallesio committed
133
       ;; Define a module for the scmpkg package
134 135
       (define-module ,name
	 ;; Imports
136
	 (import ,@allimp)
137
	 ;; Exports
138
	 ,(do-exports exp)
139
	 ;; Body
140 141 142
	 (include ,(scmpkg-package-source pkg))
	 ;; Publish macros and syntaxes 
	 ,(publish-syntaxes macs))
143 144 145 146 147 148 149 150 151
       ;; Provide
       (provide ,(symbol->string name)))))

;; ======================================================================
;;	parse-interface ...
;; ======================================================================
(define (parse-interface name body)

  (define (choose-language pkg lang)
Erick Gallesio's avatar
Erick Gallesio committed
152 153
    (let* ((lg   (if (pair? lang) (car lang) lang))
	   (info (assoc lg *scmpkg-languages*)))
154
      (unless info
Erick Gallesio's avatar
Erick Gallesio committed
155
	(error 'interface "Language '~S' is not managed" lg))
156
      ;; Set the language
Erick Gallesio's avatar
Erick Gallesio committed
157
      (set! (scmpkg-package-language pkg) lang)
158
      ;; Set the default suffix
Erick Gallesio's avatar
Erick Gallesio committed
159 160
      (unless (scmpkg-package-suffix pkg)
	(set! (scmpkg-package-suffix pkg) (key-get (cdr info) :suffix)))))
161 162 163 164 165 166 167 168

  (define (patch-package-export-list! pkg)
    (let ((exports '()))
      (for-each
          (lambda (x)
	    (if (symbol? x)
	      (%push! exports x)			     ;; export a variable
	      (match-case x
169 170
		 ((from ?mod . ?rest)			     ;; re-exportation
		  (%push! exports x))
171 172
		 ((macro (?name . ?rest))		     ;; export a macro
		  (%push! (scmpkg-package-macros pkg) name))
173
		 ((syntax ?args . ?-)			     ;; export a syntax
Erick Gallesio's avatar
Erick Gallesio committed
174
		  (%push! (scmpkg-package-syntaxes pkg) args))
175 176
		 (else
		  (%push! exports (car x))))))
Erick Gallesio's avatar
Erick Gallesio committed
177 178
	  (scmpkg-package-exports pkg))
      (set! (scmpkg-package-exports pkg) exports)))
179 180 181
  
  (define (patch-package! pkg)
    ;; Language & suffix
Erick Gallesio's avatar
Erick Gallesio committed
182
    (choose-language pkg (scmpkg-package-language pkg))
183
    ;; Source 
Erick Gallesio's avatar
Erick Gallesio committed
184 185 186
    (unless (scmpkg-package-source pkg)
      (set! (scmpkg-package-source pkg)
	(format "~a.~a" name (scmpkg-package-suffix pkg))))
187 188 189 190 191
    ;; Arrange the export list
    (patch-package-export-list! pkg)
    ;; Return the updated package
    pkg)
  
Erick Gallesio's avatar
Erick Gallesio committed
192
  (let ((pkg (%new-scmpkg-package name)))
193 194 195
    (for-each (lambda (clause)
		(match-case clause
		  ((version  ?version)
Erick Gallesio's avatar
Erick Gallesio committed
196
		   (set! (scmpkg-package-version pkg) version))
Erick Gallesio's avatar
Erick Gallesio committed
197
		  ((language . ?lg)
Erick Gallesio's avatar
Erick Gallesio committed
198
		   (set! (scmpkg-package-language pkg) lg))
199
		  ((source ?src)
Erick Gallesio's avatar
Erick Gallesio committed
200
		   (set! (scmpkg-package-source pkg) src))
201
		  ((suffix ?sfx)
Erick Gallesio's avatar
Erick Gallesio committed
202
		   (set! (scmpkg-package-suffix pkg) sfx))
203
		  ((import . ?imp)
Erick Gallesio's avatar
Erick Gallesio committed
204
		   (set! (scmpkg-package-imports pkg) imp))
205
		  ((export . ?exp)
Erick Gallesio's avatar
Erick Gallesio committed
206
		   (set! (scmpkg-package-exports pkg) exp))
207
		  (else
208 209 210
		   (unless (and (pair? clause)
				(memq (car clause) *ignored-interface-clauses*))
		     (error 'interface "Invalid clause ~S" clause)))))
211 212
	      body)
    (patch-package! pkg)))
Erick Gallesio's avatar
Erick Gallesio committed
213 214 215 216


;; ======================================================================
(export scmpkg-package-exports scmpkg-package-imports scmpkg-package-language
217 218
;;//	scmpkg-package-exceptions scmpkg-package-records
	scmpkg-package-source)