Commit 4120e59b authored by Erick Gallesio's avatar Erick Gallesio

Various small fixes

parent d52715ac
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 26-Feb-2000 10:47 (eg)
;;;; Last file update: 10-May-2007 16:32 (eg)
;;;; Last file update: 6-Jun-2007 09:11 (eg)
;;;;
(define-module STKLOS-COMPILER
......@@ -985,7 +985,9 @@ doc>
tail?))
((and (small-integer-constant? a)
(memq fct '(fx+ fx*))) ; commutative only
(oper2 (if (eq? fct 'fx+) 'IN-SINT-ADD2 'INT-SINT-MUL2)
(oper2 (if (eq? fct 'fx+)
'IN-SINT-FXADD2
'INT-SINT-FXMUL2)
b a))
((small-integer-constant? b)
(oper2 (case fct
......
......@@ -24,7 +24,7 @@
;;;; Manuel Serrano.
;;;;
;;;; Creation date: 14-May-2007 19:12 (eg)
;;;; Last file update: 15-May-2007 16:44 (eg)
;;;; Last file update: 5-Jun-2007 14:28 (eg)
;;;;
(define-module HTTP-MODULE
......@@ -298,12 +298,18 @@
(cond
((input-port? pt)
pt)
((and (list? pt) (= (length pt) 3))
((and (list? pt) (= (length pt) 3) (eq? (car pt) 'redirection))
;; We have a redirection (redirection old-port new-url)
(close-input-port (cadr pt))
(open-url (format "http://~a:~a~a" host port (caddr pt))))
(let* ((old-port (cadr pt))
(new-url (caddr pt))
(uri (uri-parse new-url)))
(close-input-port old-port)
(let ((url (if (equal? (key-get uri :scheme #f) "http")
new-url
(format "http://~a:~a~a" host port new-url))))
(open-url url))))
(else
(error "unexpected result ~S" pt))))))
(error 'http-download "unexpected result ~S" pt))))))
(let ((port (open-url url)))
(cond
......
# Makefile for stklos-pkgman
# Author: Erick Gallesio [eg@essi.fr]
# Creation date: 22-Dec-2006 12:00 (eg)
# Last file update: 31-May-2007 14:25 (eg)
# Last file update: 5-Jun-2007 14:25 (eg)
makefiledir= $(prefix)/etc/stklos
......@@ -12,7 +12,8 @@ bin_SCRIPTS = stklos-pkg
LEX = lang-bigloo.l lang-chicken.l lang-mzscheme.l
LEXOBJS = lang-bigloo.inc lang-chicken.inc lang-mzscheme.inc
SRC = main.stk add.stk copy.stk extract.stk install.stk lang.stk \
SRC = ../lib/http.stk \
main.stk add.stk copy.stk extract.stk install.stk lang.stk \
params.stk pkgball.stk \
repository.stk rewrite.stk misc.stk tune.stk types.stk
SFLAGS =
......
......@@ -17,7 +17,7 @@
# Makefile for stklos-pkgman
# Author: Erick Gallesio [eg@essi.fr]
# Creation date: 22-Dec-2006 12:00 (eg)
# Last file update: 31-May-2007 14:25 (eg)
# Last file update: 5-Jun-2007 14:25 (eg)
VPATH = @srcdir@
......@@ -190,7 +190,8 @@ makefile_DATA = etc/Makefile-scmpkg.tmpl
bin_SCRIPTS = stklos-pkg
LEX = lang-bigloo.l lang-chicken.l lang-mzscheme.l
LEXOBJS = lang-bigloo.inc lang-chicken.inc lang-mzscheme.inc
SRC = main.stk add.stk copy.stk extract.stk install.stk lang.stk \
SRC = ../lib/http.stk \
main.stk add.stk copy.stk extract.stk install.stk lang.stk \
params.stk pkgball.stk \
repository.stk rewrite.stk misc.stk tune.stk types.stk
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 18-Jan-2007 16:59 (eg)
;;;; Last file update: 24-Mar-2007 16:17 (eg)
;;;; Last file update: 5-Jun-2007 15:50 (eg)
;;;;
......@@ -34,7 +34,7 @@
;; Control name validity
(unless package
(die (format "Incorrect pkgball name ~S" pkgball)))
(when (negative? (version-number->integer version))
(when (negative? (version-number->integer version #f))
(die (format "Bad version number for pkgball ~S" pkgball)))
(let ((dirname (temporary-file-name)))
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 14-Jan-2007 13:37 (eg)
;;;; Last file update: 1-Jun-2007 10:37 (eg)
;;;; Last file update: 5-Jun-2007 15:21 (eg)
;;;;
;; ----------------------------------------------------------------------
......@@ -56,8 +56,10 @@
;; ----------------------------------------------------------------------
;; version-number->integer ...
;; ----------------------------------------------------------------------
(define (version-number->integer str)
(define (version-number->integer str release)
;; Files without release (i.e. the one in the local repository)
;; are given the 9999 pseudo release number. This insure that
;; they are greater than the ones on a distant directory
(define (fmt n)
(cond
((< n 10) (format "000~a" n))
......@@ -65,10 +67,12 @@
((< n 1000) (format "0~a" n))
(else (number->string n))))
(let ((v (map string->number (string-split str "."))))
(let ((r (or release 9999))
(v (map string->number (string-split str "."))))
(if (and (= (length v) 3)
(every integer? v))
(string->number (format "~A~A~A" (car v) (fmt (cadr v)) (fmt (caddr v))))
(string->number (format "~A~A~A~A" (car v) (fmt (cadr v)) (fmt (caddr v))
(fmt r)))
-1)))
;; ----------------------------------------------------------------------
......@@ -78,9 +82,11 @@
(let ((n1 (package-name p1))
(n2 (package-name p2))
(v1 (package-version p1))
(v2 (package-version p2)))
(v2 (package-version p2))
(r1 (package-release p1))
(r2 (package-release p2)))
(if (string=? n1 n2)
(< (version-number->integer v1) (version-number->integer v2))
(< (version-number->integer v1 r1) (version-number->integer v2 r2))
(string<? n1 n2))))
;; ----------------------------------------------------------------------
......@@ -107,22 +113,24 @@
(map (lambda (x) (format "_~a-~a" main x)) (cdr lang)))))
(define (deps* package)
(let* ((pkg (find-package package))
(lang (package-language pkg))
(deps (map (lambda (x)
(let ((name (car x))
(vers (cadr x)))
(if (equal? vers "*")
name
(format "~a-~a" name vers))))
(package-dependencies pkg)))
(all (if (member (car lang) '(stklos r5rs))
deps
(append (build-lang-deps lang) deps))))
(if (null? all)
all
(append (apply append (map deps* all))
all))))
(let ((pkg (find-package package)))
(unless pkg
(error-pkg 'package-deps* "cannot find package ~S" package))
(let* ((lang (package-language pkg))
(deps (map (lambda (x)
(let ((name (car x))
(vers (cadr x)))
(if (equal? vers "*")
name
(format "~a-~a" name vers))))
(package-dependencies pkg)))
(all (if (member (car lang) '(stklos r5rs))
deps
(append (build-lang-deps lang) deps))))
(if (null? all)
all
(append (apply append (map deps* all))
all)))))
;;
;; package-deps* starts here
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 26-Dec-2006 18:20 (eg)
;;;; Last file update: 30-May-2007 18:08 (eg)
;;;; Last file update: 5-Jun-2007 16:00 (eg)
;;;;
......@@ -58,6 +58,7 @@
(define (add-package name options)
(let ((new (new-package name
:version (key-get options :version "0.0.0")
:release (key-get options :release #f)
:language (key-get options :language '(r5rs))
:category (key-get options :category #f)
:path (key-get options :path #f)
......@@ -75,6 +76,7 @@
(let ((new (new-tuning name
:host (key-get options :host)
:version (key-get options :version "0.0.0")
:release (key-get options :release #f)
:path (key-get options :path "")
:url (key-get options :url "")
:md5 (key-get options :md5 ""))))
......@@ -102,15 +104,28 @@
(for-each add-description lst)))))
(define (add-tuning-to-package tuning)
(define (release>? a b)
(cond
((not a) #t) ; a is unnumbered (it is a local file)
((not b) #f) ; b is unnumbered (it is a local file)
(else (> a b))))
;; This is only called for STklos tunings
(let* ((name (tuning-name tuning))
(version (tuning-version tuning))
(release (tuning-release tuning))
(items (filter (lambda (x) (and (equal? (package-name x) name)
(equal? (package-version x) version)))
*all-packages*)))
(if (null? items)
(eprintf "Warning: no package for tuning ~a-~a" name version)
(set! (package-tuning (car items)) tuning))))
(let ((old-tuning (package-tuning (car items))))
(if (or (not old-tuning)
(release>? release (tuning-release old-tuning)))
;; This is the first tuning we see or its release number is greater
;; than the one we have already stored in our db
(set! (package-tuning (car items)) tuning))))))
;;;
;;; load-repository-descriptions starts here
;;;
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 13-Jan-2007 23:24 (eg)
;;;; Last file update: 12-Mar-2007 00:05 (eg)
;;;; Last file update: 5-Jun-2007 15:13 (eg)
;;;;
;; ----------------------------------------------------------------------
......@@ -30,6 +30,7 @@
(define-struct package
name
version
release
language
category
path
......@@ -43,12 +44,14 @@
tuning
suffix)
(define (new-package name :key version language category path url md5 description
author failures dependencies provides tuning suffix)
(define (new-package name :key version release language category path url md5
description author failures dependencies
provides tuning suffix)
(unless path
;; Build a path in the cache for this package
(set! path (make-path (stklos-pkg-cache-directory)
(format "~a-~a.tar.gz" name version))))
(format "~a-~a~a.tar.gz" name version
(if release (- release) "")))))
(when (string? language)
(set! language (string->symbol language)))
......@@ -57,7 +60,7 @@
((stklos ".stk"))
(else ".scm"))))
(make-package name version language category path url md5 description
(make-package name version release language category path url md5 description
author failures dependencies provides tuning suffix))
;; ----------------------------------------------------------------------
......@@ -66,14 +69,16 @@
(define-struct tuning
name
version
release
host
path
url
md5)
(define (new-tuning name :key version host path url md5)
(define (new-tuning name :key version release host path url md5)
(unless path
;; Build a path in the cache for this tuning
(set! path (make-path (stklos-pkg-cache-directory)
(format "~a_~a-~a.tar.gz" name host version))))
(make-tuning name version host path url md5))
(format "~a_~a-~a~a.tar.gz" name host version
(if release (- release) "")))))
(make-tuning name version release host path url md5))
This diff is collapsed.
This diff is collapsed.
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@essi.fr]
* Creation date: 9-May-2007 17:15 (eg)
* Last file update: 1-Jun-2007 20:11 (eg)
* Last file update: 5-Jun-2007 19:45 (eg)
*/
#include <stklos.h>
......@@ -106,11 +106,12 @@ DEFINE_PRIMITIVE("fx+", fxplus, subr2, (SCM o1, SCM o2))
DEFINE_PRIMITIVE("fx-", fxminus, subr12, (SCM o1, SCM o2))
{
STk_debug("On fait fx- ~S ~S", o1 ,o2);
if (!INTP(o1)) error_bad_fixnum(o1);
if (!o2)
return MAKE_INT(-INT_VAL(o1));
if (!INTP(o2)) error_bad_fixnum(o2);
return MAKE_INT(INT_VAL(o1) + INT_VAL(o2));
return MAKE_INT(INT_VAL(o1) - INT_VAL(o2));
}
DEFINE_PRIMITIVE("fx*", fxtime, subr2, (SCM o1, SCM o2))
......
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 1-Mar-2000 19:51 (eg)
* Last file update: 10-May-2007 15:51 (eg)
* Last file update: 6-Jun-2007 09:14 (eg)
*/
// INLINER values
......@@ -1399,7 +1399,7 @@ CASE(IN_SINT_DIV2) { REG_CALL_PRIM(division);
CASE(IN_SINT_FXADD2) { REG_CALL_PRIM(fxplus);
vm->val = STk_fxplus(vm->val, MAKE_INT(fetch_next())); NEXT1;}
CASE(IN_SINT_FXSUB2) { REG_CALL_PRIM(fxminus);
vm->val = STk_fxminus(MAKE_INT(fetch_next()), vm->val); NEXT1;}
vm->val = STk_fxminus(vm->val, MAKE_INT(fetch_next())); NEXT1;}
CASE(IN_SINT_FXMUL2) { REG_CALL_PRIM(fxtime);
vm->val = STk_fxtime(vm->val, MAKE_INT(fetch_next())); NEXT1;}
CASE(IN_SINT_FXDIV2) { REG_CALL_PRIM(fxdiv);
......
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