Commit 88787735 authored by Erick Gallesio's avatar Erick Gallesio

Adding snowman prototype

parent c6c9731c
......@@ -2,11 +2,11 @@
#
# Author: Erick Gallesio [eg@unice.fr]
# Creation date: 11-Apr-2000 10:30 (eg)
# Last file update: 28-Oct-2006 18:12 (eg)
# Last file update: 11-Jan-2007 16:29 (eg)
EXTRA_DIST =
SUBDIRS = @PCRE@ @GC@ @GMP@ src utils lib @GTKLOS@ @EXAMPLES@ \
extensions tests doc
snowman extensions tests doc snowman
SVN_URL = @SVN_URL@/STklos
VERSION_TAG = @PACKAGE@-@VERSION@
VERSION_BETA = $(VERSION_TAG)-beta
......
......@@ -18,7 +18,7 @@
#
# Author: Erick Gallesio [eg@unice.fr]
# Creation date: 11-Apr-2000 10:30 (eg)
# Last file update: 28-Oct-2006 18:12 (eg)
# Last file update: 11-Jan-2007 16:29 (eg)
srcdir = @srcdir@
top_srcdir = @top_srcdir@
VPATH = @srcdir@
......@@ -204,7 +204,7 @@ sysconfdir = @sysconfdir@
target_alias = @target_alias@
EXTRA_DIST =
SUBDIRS = @PCRE@ @GC@ @GMP@ src utils lib @GTKLOS@ @EXAMPLES@ \
extensions tests doc
snowman extensions tests doc snowman
VERSION_TAG = @PACKAGE@-@VERSION@
VERSION_BETA = $(VERSION_TAG)-beta
......
......@@ -7431,7 +7431,7 @@ fi
ac_config_files="$ac_config_files Makefile src/Makefile src/extraconf.h doc/Makefile lib/Makefile gtklos/Makefile gtklos/gtklosconf.h utils/Makefile lib/boot-callcc.stk utils/stklos-config utils/stklos-script extensions/Makefile examples/Makefile examples/images/Makefile lib/Match.d/Makefile lib/SILex.d/Makefile lib/Lalr.d/Makefile lib/Lurc.d/Makefile lib/Snow.d/Makefile tests/Makefile extensions/extconf.h doc/stklos.1 doc/stklos-config.1 doc/stklos-compile.1 doc/stklos-genlex.1 doc/stklos-install.1 doc/skb/stklos-version.stk"
ac_config_files="$ac_config_files Makefile src/Makefile src/extraconf.h doc/Makefile lib/Makefile gtklos/Makefile gtklos/gtklosconf.h utils/Makefile lib/boot-callcc.stk utils/stklos-config utils/stklos-script extensions/Makefile examples/Makefile examples/images/Makefile lib/Match.d/Makefile lib/SILex.d/Makefile lib/Lalr.d/Makefile lib/Lurc.d/Makefile lib/Snow.d/Makefile tests/Makefile extensions/extconf.h doc/stklos.1 doc/stklos-config.1 doc/stklos-compile.1 doc/stklos-genlex.1 doc/stklos-install.1 doc/skb/stklos-version.stk snowman/Makefile"
cat >confcache <<\_ACEOF
# This file is a shell script that caches the results of configure
......@@ -8046,6 +8046,7 @@ do
"doc/stklos-genlex.1") CONFIG_FILES="$CONFIG_FILES doc/stklos-genlex.1" ;;
"doc/stklos-install.1") CONFIG_FILES="$CONFIG_FILES doc/stklos-install.1" ;;
"doc/skb/stklos-version.stk") CONFIG_FILES="$CONFIG_FILES doc/skb/stklos-version.stk" ;;
"snowman/Makefile") CONFIG_FILES="$CONFIG_FILES snowman/Makefile" ;;
*) { { echo "$as_me:$LINENO: error: invalid argument: $ac_config_target" >&5
echo "$as_me: error: invalid argument: $ac_config_target" >&2;}
......
......@@ -2,7 +2,7 @@ dnl configure.in for STklos
dnl
dnl Author: Erick Gallesio [eg@unice.fr]
dnl Creation date: 28-Dec-1999 21:19 (eg)
dnl Last file update: 20-Dec-2006 10:10 (eg)
dnl Last file update: 11-Jan-2007 16:27 (eg)
AC_INIT(src/stklos.c)
......@@ -518,7 +518,8 @@ AC_OUTPUT(Makefile src/Makefile src/extraconf.h doc/Makefile
tests/Makefile extensions/extconf.h
doc/stklos.1 doc/stklos-config.1 doc/stklos-compile.1
doc/stklos-genlex.1 doc/stklos-install.1
doc/skb/stklos-version.stk)
doc/skb/stklos-version.stk
snowman/Makefile)
chmod 0755 utils/stklos-config utils/stklos-script
......
;;;;
;;;; _snow.stk -- A special version of _snow package (the one used by everybody)
;;;;
;;;; Copyright 2006 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
;;;; Copyright © 2006-2007 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 21-Dec-2006 14:55 (eg)
;;;; Last file update: 22-Dec-2006 00:15 (eg)
;;;; Last file update: 17-Jan-2007 10:54 (eg)
;;;;
;//FIXME: _snow:program-filename should be defined as program-file-name
......@@ -30,8 +30,15 @@
(define-module _snow
(import SNOW)
(export snow-raise snow-error snow-with-exception-catcher
_snow:program-filename)
_snow:program-filename
snow-condition snow-type-check-condition snow-error-condition
;; FIXME
snow-exception)
;;
;; Functions
......@@ -54,16 +61,28 @@
;;
;; Exceptions
;;
(define-exception* snow-condition)
;;// (define-exception* snow-condition)
;;//
;;// (define-exception* snow-type-check-condition
;;// parent: snow-condition)
;;//
;;// (define-exception* snow-error-condition
;;// parent: snow-condition
;;// msg
;;// args))
(define-record* snow-condition)
(define-exception* snow-type-check-condition
parent: snow-condition)
(define-record* snow-type-check-condition parent: snow-condition)
(define-exception* snow-error-condition
(define-record* snow-error-condition
parent: snow-condition
msg
args))
args)
(define snow-exception snow-condition) ;; FIXME: Bigloo adaptation
)
;; ----------------------------------------------------------------------
;; Redefine all the symbols exported by _snow to the STklos module
;; so that STklos is in fact now a Snow interpreter
......
;;;;
;;;; snow-stklos.stk -- Snow packages in STklos
;;;;
;;;; Copyright 2006 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
;;;; Copyright 2006-2007 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 11-Dec-2006 14:39 (eg)
;;;; Last file update: 21-Dec-2006 15:39 (eg)
;;;; Last file update: 17-Jan-2007 11:25 (eg)
;;;;
......@@ -30,8 +30,9 @@
;; ======================================================================
(define-macro (package* name version . body)
`(begin
(require "snow-support")
(define-module ,name
(require "_snow")
;(require "_snow")
(define %%package-version ',version)
,@(package*-body-expand body))
(select-module ,name)))
......@@ -67,6 +68,21 @@
`(begin
(define ,var ,value)
(export ,var)))
;; define
((define (?var . ?args))
`(export ,var))
((define (?var . ?args) . ?rest)
`(begin
(define (,var . args) ,@rest)
(export ,var)))
((define ?var)
`(export ,var))
((define ?var ?value)
`(begin
(define ,var ,value)
(export ,var)))
;; define-macro*
((define-macro* . ?rest)
`(define-macro ,@rest))
......
;;;;
;;;; snow-record.stk -- Snow record support
;;;;
;;;; Copyright 2006 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
;;;; Copyright 2006-2007 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 21-Dec-2006 12:00 (eg)
;;;; Last file update: 21-Dec-2006 12:02 (eg)
;;;; Last file update: 17-Jan-2007 10:59 (eg)
;;;;
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 26-Feb-2000 10:47 (eg)
;;;; Last file update: 5-Jan-2007 19:43 (eg)
;;;; Last file update: 19-Jan-2007 10:17 (eg)
;;;;
(define-module STKLOS-COMPILER
......@@ -1167,22 +1167,6 @@ doc>
(Loop (cdr l)
loc)))))))))))
(define (compile-let* args env tail?)
(let ((len (length args)))
(if (< len 3)
(compiler-error 'let* args "ill formed let* ~S" args)
(let ((bindings (cadr args))
(body (cddr args)))
(when (valid-let-bindings? bindings #f)
(compile (if (<= (length bindings) 1)
`(let ,bindings ,@body)
`(let (,(car bindings))
(let* ,(cdr bindings)
,@body)))
env args tail?))))))
;;
;; COND
......
;;;;
;;;; load.stk -- Extended load function
;;;;
;;;; Copyright 2000-2006 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;; Copyright 2000-2007 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 17-May-2000 14:55 (eg)
;;;; Last file update: 13-Dec-2006 17:09 (eg)
;;;; Last file update: 17-Jan-2007 11:46 (eg)
;;;;
......@@ -156,7 +156,10 @@ doc>
(define (try f)
; (eprintf "Try ~S\n" f)
(and (file-exists? f) (file-is-readable? f) f))
(and (file-exists? f)
(file-is-readable? f)
(not (file-is-directory? f))
f))
(define (try-load-with-suffixes name suffixes)
(let Loop ((s suffixes))
......@@ -196,7 +199,7 @@ doc>
(res #f)
(out (current-error-port))
(mod (current-module)))
(when path
(when (and path (not (file-is-directory? path)))
(current-loading-file path)
(with-handler (lambda (c)
(set! %try-load-tmp (cons c %try-load-tmp))
......
;;;;
;;;; snow-support.stk -- Support Scheme Now! packages for STklos
;;;;
;;;; Copyright 2006 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
;;;; Copyright 2006-2007 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 20-Dec-2006 10:18 (eg)
;;;; Last file update: 21-Dec-2006 15:44 (eg)
;;;; Last file update: 17-Jan-2007 11:06 (eg)
;;;;
;; ======================================================================
......@@ -39,6 +39,7 @@
;; ======================================================================
;; bootstrap
;; ======================================================================
(require-for-syntax "Snow.d/snow-record.stk")
(include "Snow.d/_snow.stk")
(provide "snow-support")
......
# Makefile for stklos-snowman
# Author: Erick Gallesio [eg@essi.fr]
# Creation date: 22-Dec-2006 12:00 (eg)
# Last file update: 18-Jan-2007 16:41 (eg)
makefiledir= $(prefix)/etc/stklos
makefile_DATA= etc/Makefile-snow.tmpl
bin_SCRIPTS = stklos-snowman
SRC = main.stk extract.stk params.stk repository.stk \
snowball.stk misc.stk types.stk
SFLAGS = -l
RM = /bin/rm
SCC = ../utils/stklos-compile
$(bin_SCRIPTS): $(SRC)
$(SCC) $(SFLAGS) -o $(bin_SCRIPTS) main.stk
clean:
$(RM) -f $(bin_SCRIPTS) *~
distclean: clean
$(RM) -f config.stk
This diff is collapsed.
;;;;
;;;; add.stk -- Adding a file to local snowfort
;;;;
;;;; 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: 18-Jan-2007 16:59 (eg)
;;;; Last file update: 18-Jan-2007 17:12 (eg)
;;;;
;; ----------------------------------------------------------------------
;; local-snowfort-add! ...
;; ----------------------------------------------------------------------
(define (local-snowfort-add! snowball)
(let* ((local (make-path (snowman-snowforts-directory) "local"))
(in (open-file local "r")))
(unless in
(die (format "Cannot open local snowfort (~a)" local)))
(let ((content (read pkg in))
(info (extract-package-informations pkg)))
(close-port in)
;; ----------------------------------------------------------------------
;; extract-package-informations ...
;; ----------------------------------------------------------------------
(define (extract-package-informations snowball
\ No newline at end of file
# -*- Makefile -*- Automatically generated for snow
# The main package
PKG=@PKG@
PKGVERS=@PKGVERS@
# Compiler
SCC=stklos-compile
SFLAGS=
SO=@SO@
SCOMP=@SCOMP@
SLINK=@SLINK@
# Targets
OSTK=@OSTK@
# General rules
all: $(OSTK) $(PKGVERS).$(SO)
clean:
/bin/rm -f $(OSTK) $(PKGVERS).{c,stk,$(SO),o}
$(PKGVERS).ostk: src/$(PKG)/$(PKG).snow
(cd src/$(PKG); $(SCC) $(SFLAGS) -o ../../$(PKG).ostk $(PKG).snow)
$(PKGVERS).$(SO): $(PKGVERS).c
$(SCOMP) -c -DMODULE_ENTRY=1 -o $(PKGVERS).o $(PKGVERS).c
$(SLINK) $(PKGVERS).so $(PKGVERS).o
/bin/rm -f $(PKGVERS).o
$(PKGVERS).c: $(PKGVERS).stk
$(SCC) -C -o $(PKGVERS).c $(PKGVERS).stk
# Rules for imported packages
;;;;
;;;; extract.stk -- Implementation of snowman extract option
;;;;
;;;; 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: 15-Jan-2007 12:10 (eg)
;;;; Last file update: 18-Jan-2007 16:54 (eg)
;;;;
;; ----------------------------------------------------------------------
;; write-extract-makefile ...
;; ----------------------------------------------------------------------
(define (write-extract-makefile package targets dir)
(define (find-src name)
(let ((snow (make-path "src" name (format "~a.snow" name)))
(scm (make-path "src" name (format "~a.scm" name))))
(if (file-exists? (make-path dir snow)) snow scm)))
(define (make-entry name)
(let ((src (find-src name)))
(printf "~a.ostk: ~a\n" name src)
(printf "\t(cd src/~a; $(SCC) $(SFLAGS) -o ../../~a.ostk ~a)\n\n"
name name (basename src))))
(define (make-library-entry)
(printf "\n#Source of library ~s\n" package)
(printf "$(PKGVERS).stk:\n")
(printf "\techo -n > $(PKGVERS).stk\n")
;; Produce provides
(for-each (lambda (x)
(printf "\techo '(provide ~s)' > $(PKGVERS).stk\n" x))
targets)
;; Produce inclusion of required packages + the package itself
(for-each (lambda (x)
(printf "\techo '(include ~s)' > $(PKGVERS).stk\n"
(find-src x)))
(append targets (list (package-sans-version package)))))
(let* ((tmpl (make-path (%library-prefix) "etc" "stklos" "Makefile-snow.tmpl"))
(in (open-file tmpl "r")))
(if in
(let ((str (port->string in))
(flat (open-output-string)))
;; Create the list of all the module to build
(for-each (lambda (x) (format flat " ~a.ostk \\\n"x)) targets)
(format flat " $(PKGVERS).ostk\n")
;; Build Makefile
(with-output-to-file (make-path dir "Makefile")
(lambda ()
;; Header
(display (sed str
`(("@OSTK@" ,(get-output-string flat))
("@PKGVERS@" ,package)
("@PKG@" ,(package-sans-version package))
("@SO@" ,(exec "stklos-config --shared-suffix"))
("@SCOMP@" ,(exec "stklos-config --compile"))
("@SLINK@" ,(exec "stklos-config --link")))))
(newline)
;; Build the entries for required packages
(for-each make-entry targets)
;; Build the source of the "library"
(make-library-entry)
(printf "# End of Makefile\n"))))
(eprintf "Warning: cannot find template Makefile ~S\n" tmpl))))
;; ----------------------------------------------------------------------
;; find-and-extract-package ...
;; ----------------------------------------------------------------------
(define (find-and-extract-package package dir)
(define (extract-package package dir)
(let ((src-dir (make-path dir "src")))
(unless (file-exists? src-dir)
(make-directories src-dir))
(let ((snowball (package-snowball package)))
(unless (file-exists? snowball)
(die (format "cannot find snowball in cache ~s" snowball)))
(untar snowball src-dir)
(tune-package package src-dir))))
(let ((pkg (download-package package))
(deps (package-deps* package)))
;; package (as well as its dependencies) is now in the cache.
;; extract all its dependencies
(for-each (lambda (x) (extract-package (find-package x) dir))
deps)
;; extract the package itself
(extract-package pkg dir)
;; Create a Makefile for building package
(write-extract-makefile package deps dir)))
;;;;
;;;; http.stk -- Minimal HTTP management for snowman
;;;;
;;;; 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-Jan-2007 09:03 (eg)
;;;; Last file update: 12-Jan-2007 17:07 (eg)
;;;;
(define (http-get url output)
;; Copy the content of url to the output port
(define (skip-header port)
(let loop ((line (read-line port)))
(unless (or (eof-object? line) (string=? line ""))
(loop (read-line port)))))
(define (copy-url server port user path)
(let* ((s (make-client-socket server port))
(out (socket-output s))
(in (socket-input s)))
;; Send HTTP request
(fprintf out "GET ~a HTTP/1.0\r\n" path)
(fprintf out "Host: ~a\r\n" server)
(fprintf out "Port: ~a\r\n" port)
(when user
(fprintf out "Authorization: Basic ~a\r\n" (base64-encode-string user)))
(fprintf out "Connection: close\r\n")
(fprintf out "\r\n")
(flush-output-port out)
;; Read header
(let ((line (read-line in)))
(if (regexp-match "[Hh][Tt][Tt][Pp].* +200 +.*" line)
;; The request is correct. Skip the header
(skip-header in)
(error "cannot get the document at url ~s. code ~s" url line)))
;; copy the content of the url on output
(copy-port in output)
(socket-shutdown s #t)))
(let ((info (uri-parse url)))
(unless (equal? (key-get info :scheme) "http")
(error "bad url (protocol is not http) ~S" url))
(let ((user (key-get info :user #f))
(host (key-get info :host))
(port (key-get info :port))
(path (key-get info :path)))
(copy-url host port user path))))
;;;;
;;;; main.stk -- Snowman main program
;;;;
;;;; 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: 22-Dec-2006 11:32 (eg)
;;;; Last file update: 18-Jan-2007 16:37 (eg)
;;;;
(include "types.stk")
(include "params.stk")
(include "http.stk")
;;(include "snowball.stk")
(include "repository.stk")
(include "extract.stk")
(include "misc.stk")
;; ----------------------------------------------------------------------
;; snowman-arguments ...
;; ----------------------------------------------------------------------
(define (snowman-arguments argv)
(let ((actions '()))
(parse-arguments argv
"Usage: stklos-snowman [options] [parameter ...]"
"Actions"
(("extract" :arg pkg :alternate "e" :help "Extract <pkg>. Don't install it")
(set! actions (cons (list 'extract pkg) actions)))
(("add" :alternate "a" :arg sb
:help "Add <sb> snowball to the local repository")
1111111)
"Informations"
(("depends" :arg pkg :help "Show all the dependencies of <pkg>")
(set! actions (cons (list 'package-deps pkg) actions)))
"Repository administration"
(("sync" :alternate "s" :help "synchronize with remote snowfort servers")
(set! actions (cons 'sync actions)))
(("list" :alternate "l" :help "list available packages")
(set! actions (cons 'list actions)))
(("delete-repository" :help "delete snowman repository. USE WITH CAUTION")
(set! actions (cons 'delete-repo actions)))
"Misc"
(("directory" :arg dir :alternate "C"
:help "Change to directory <dir> when extracting")
(snowman-extract-dir dir))
(("verbose" :alternate "v" :help "be verbose (can be cumulated)")
(snowman-verbosity (+ (snowman-verbosity) 1)))
(("help" :alternate "h" :help "display this help")
(arg-usage (current-error-port))
(exit 0))
(("options" :help "display program options")
(arg-usage (current-error-port) #t)
(exit 0))
(("version" :alternate "V" :help "print the version and exit")
(eprintf "stklos-snowman shipped with STklos (version ~A)\n" (version))
(exit 0)))
(if (null? actions)
'(list)
(reverse actions))))
;; ----------------------------------------------------------------------
;; main ...
;; ----------------------------------------------------------------------
(define (main argv)
;; Ensure that files are correctly set
(ensure-repository-hierarchy)
;; load the snowforts informations
(load-repository-descriptions)
;; Parse the program arguments
(let loop ((actions (snowman-arguments argv)))
(unless (null? actions)
(case ((if (pair? (car actions)) caar car) actions)
((list)
(list-repository-packages))
((sync)
(synchronize-snowforts))
((delete-repo)
(rm-rf (snowman-cache-directory))
(rm-rf (snowman-snowforts-directory))
(exit 0))
((extract)
(find-and-extract-package (cadar actions)
(snowman-extract-dir)))
((package-deps)
(for-each (lambda (x) (printf "~a\n" x))
(package-deps* (cadar actions))))
(else (die (format "bad command ~S" (car actions)))))
(loop (cdr actions))))
(exit 0))
;;;;
;;;; misc.stk -- Misc functions for snowman
;;;;
;;;; 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: 14-Jan-2007 13:37 (eg)
;;;; Last file update: 17-Jan-2007 23:12 (eg)
;;;;
;; ----------------------------------------------------------------------
;; package<? ...
;; ----------------------------------------------------------------------
(define (package<? p1 p2)
(define (version-value v)
(let ((v (map string->number (string-split v "."))))
(if (and (= (length v) 3)
(every number? v))
(+ (* (car v) 1000000)
(* (cadr v) 1000)
(* (caddr v) 1))
0)))
(let ((n1 (package-name p1))
(n2 (package-name p2))
(v1 (package-version p1))
(v2 (package-version p2)))
(if (string=? n1 n2)
(< (version-value v1) (version-value v2))
(string<? n1 n2))))
;; ----------------------------------------------------------------------
;; snowfort-names ...
;; ----------------------------------------------------------------------
(define (snowfort-names)
(cons "local" (map car (snowman-sync-urls))))
;; ----------------------------------------------------------------------
;; package-deps* ...
;; ----------------------------------------------------------------------
(define (package-deps* package)
(define (deps* package)
(let* ((pkg (find-package package))
(deps (map (lambda (x) (string-append (car x) (cadr x)))
(package-dependencies pkg))))
(if (null? deps)
deps
(append deps (apply append (map deps* deps))))))
(define (list->set lst res)
(cond
((null? lst)
res)
((member (car lst) res)
(list->set (cdr lst) res))
(else
(list->set (cdr lst) (cons (car lst) res)))))
(list->set (deps* package) '()))
;; ----------------------------------------------------------------------
;; package-sans-version ...
;; ----------------------------------------------------------------------
(define (package-sans-version str)