Commit a5ba0efd authored by Erick Gallesio's avatar Erick Gallesio

Bug Fix in C parameters

parent 6731a351
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 15-Jan-2007 12:10 (eg)
;;;; Last file update: 17-Apr-2007 12:32 (eg)
;;;; Last file update: 22-May-2007 10:25 (eg)
;;;;
;; ----------------------------------------------------------------------
......@@ -65,7 +65,31 @@
(format "~a-test.ostk" package)
package))
(printf "\t@echo '**** No test provided with package ~A'\n" package))))
(define (build-install-target targets system-wide?)
(let ((prefix (if system-wide? "system-" "")))
(printf "~ainstall: $(OBJ)\n" prefix)
(for-each (lambda (x)
(let* ((tunedir (make-path package "stklos"))
(tuneconf (make-path tunedir "configure"))
(docdir (make-path package "doc"))
(obj (format "~a.~a" x
(if (file-exists? tuneconf)
"$(SO)"
"ostk")))
(docs (cddr (directory-files docdir))))
;; installing the object file
(printf "\tstklos-ext-install ~ascmpkg ~a ~a 0755 && \\\n"
prefix x obj)
;; installing the doc files
(for-each
(lambda (d)
(printf "\tstklos-ext-install ~ascmpkg ~a doc/~a 0744 && \\\n"
prefix x d))
docs)))
targets)
(printf "\techo '~ainstall done.'\n\n" prefix)))
;;;
;;; write-extract-file starts here
;;;
......@@ -92,6 +116,9 @@
(newline)
(display tmp)
(build-test-target)
(let ((all (append! targets (list package))))
(build-install-target all #f)
(build-install-target all #t))
(display "\n# End of Makefile\n"))))))
......@@ -132,3 +159,19 @@
(extract-package pkg dir)
;; Create the Makefile able to build the package
(write-extract-makefile package (package-version pkg) deps dir)))
;; ----------------------------------------------------------------------
;; find-extract-and-test-package ...
;; ----------------------------------------------------------------------
(define (find-extract-and-test-package package tmpdir)
(dynamic-wind
list
(lambda ()
(find-and-extract-package package tmpdir)
(when (> (stklos-pkg-verbosity) 0)
(eprintf "Start Testing package ~S in directory ~S\n" package tmpdir))
(test-package package tmpdir))
(lambda()
(when (> (stklos-pkg-verbosity) 0)
(eprintf "Deleting build directory ~S\n" tmpdir))
(rm-rf tmpdir))))
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 22-Dec-2006 11:32 (eg)
;;;; Last file update: 15-May-2007 16:30 (eg)
;;;; Last file update: 21-May-2007 15:24 (eg)
;;;;
(include "../lib/http.stk")
......@@ -50,7 +50,8 @@
"Actions"
(("extract" :arg pkg :alternate "e" :help "Extract <pkg>. Don't install it")
(set! actions (cons (list 'extract pkg) actions)))
(("test" :arg pkg :alternate "t" :help "Test <pkg>.")
(set! actions (cons (list 'test pkg) actions)))
"Informations"
(("depends" :arg pkg :help "Show all the dependencies of <pkg>")
(set! actions (cons (list 'package-deps pkg) actions)))
......@@ -134,6 +135,9 @@
((extract)
(find-and-extract-package (cadar actions)
(stklos-pkg-extract-dir)))
((test)
(exit (find-extract-and-test-package (cadar actions)
(temporary-file-name))))
((package-deps)
(for-each (lambda (x) (printf "~a\n" x))
(package-deps* (cadar actions))))
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 14-Jan-2007 13:37 (eg)
;;;; Last file update: 15-May-2007 15:49 (eg)
;;;; Last file update: 23-May-2007 17:08 (eg)
;;;;
;; ----------------------------------------------------------------------
......@@ -159,15 +159,6 @@
(system (format "tar xfz ~a -C ~a" file directory)))
;;//;; ----------------------------------------------------------------------
;;//;; md5sum-file ...
;;//;; ----------------------------------------------------------------------
;;//(define (md5sum-file filename)
;;// (with-input-from-file (format "| md5sum ~a" filename)
;;// (lambda ()
;;// (read-chars 32))))
;;//
;; ----------------------------------------------------------------------
;; sed ...
;; ----------------------------------------------------------------------
......@@ -184,3 +175,10 @@
;;// (let ((res (glob (make-path (stklos-ext-db-directory) package))))
;;// (not (null? res))))
;;//
;; ----------------------------------------------------------------------
;; test-package ...
;; ----------------------------------------------------------------------
(define (test-package name dir)
(system (format "cd ~a; echo 'Testing ~a'; make test" dir name)))
\ No newline at end of file
/*
* fixnum.c -- Fixnum operations
*
* 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-May-2007 17:15 (eg)
* Last file update: 10-May-2007 15:14 (eg)
*/
#include <stklos.h>
static void error_bad_fixnum(SCM obj)
{
STk_error("bad fixnum ~S", obj);
}
DEFINE_PRIMITIVE("fixnum?", fixnump, subr1, (SCM obj))
{
return MAKE_BOOLEAN(INTP(obj));
}
DEFINE_PRIMITIVE("fixnum-width", fixnum_width, subr0, (void))
{
return MAKE_INT(sizeof(long)* 8 - 2);
}
DEFINE_PRIMITIVE("least-fixnum", least_fixnum, subr0, (void))
{
return MAKE_INT(INT_MIN_VAL);
}
DEFINE_PRIMITIVE("greatest-fixnum", greatest_fixnum, subr0, (void))
{
return MAKE_INT(INT_MAX_VAL);
}
/*
* fx+, fx-, fx*, fx/, fxmod
*
*/
#define SIMPLE_OP(name, func, op) \
DEFINE_PRIMITIVE(name, func, subr2, (SCM o1, SCM o2)) \
{ \
if (!INTP(o1)) error_bad_fixnum(o1); \
if (!INTP(o2)) error_bad_fixnum(o2); \
return MAKE_INT(INT_VAL(o1) op INT_VAL(o2)); \
}
SIMPLE_OP("fx+", fxplus, +)
SIMPLE_OP("fx-", fxminus, -)
SIMPLE_OP("fx*", fxtime, *)
SIMPLE_OP("fxdiv", fxdiv, /)
SIMPLE_OP("fxmod", fxmod, %)
/*
* fx<, fx<=, fx>, fx>=, fx=
*
*/
#define SIMPLE_COMP(name, func, op) \
DEFINE_PRIMITIVE(name, func, subr2, (SCM o1, SCM o2)) \
{ \
if (!INTP(o1)) error_bad_fixnum(o1); \
if (!INTP(o2)) error_bad_fixnum(o2); \
return MAKE_BOOLEAN(INT_VAL(o1) op INT_VAL(o2)); \
}
SIMPLE_COMP("fx<", fxlt, <)
SIMPLE_COMP("fx<=", fxle, <=)
SIMPLE_COMP("fx>", fxgt, >)
SIMPLE_COMP("fx>=", fxge, >=)
SIMPLE_COMP("fx=", fxeq, ==)
int STk_init_fixnum(void)
{
ADD_PRIMITIVE(fixnump);
ADD_PRIMITIVE(fixnum_width);
ADD_PRIMITIVE(least_fixnum);
ADD_PRIMITIVE(greatest_fixnum);
ADD_PRIMITIVE(fxplus);
ADD_PRIMITIVE(fxminus);
ADD_PRIMITIVE(fxtime);
ADD_PRIMITIVE(fxdiv);
ADD_PRIMITIVE(fxmod);
ADD_PRIMITIVE(fxlt);
ADD_PRIMITIVE(fxle);
ADD_PRIMITIVE(fxgt);
ADD_PRIMITIVE(fxge);
ADD_PRIMITIVE(fxeq);
return TRUE;
}
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@kaolin.unice.fr]
* Creation date: 12-May-1993 10:34
* Last file update: 9-May-2007 17:15 (eg)
* Last file update: 24-May-2007 09:28 (eg)
*/
......@@ -3228,8 +3228,8 @@ int STk_init_number(void)
/* Add parameter for float numbers precision */
STk_make_C_parameter("real-precision",
MAKE_INT(real_precision),
real_precision_conv);
real_precision_conv,
STk_STklos_module);
// ADD_PRIMITIVE(fxplus);
return TRUE;
}
/*
* parameter.c -- Parameter Objects (SRFI-39)
*
* Copyright 2003-2006 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
* Copyright 2003-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@essi.fr]
* Creation date: 1-Jul-2003 11:38 (eg)
* Last file update: 24-Oct-2006 17:08 (eg)
* Last file update: 23-May-2007 14:22 (eg)
*/
......@@ -77,7 +77,7 @@ SCM STk_set_parameter(SCM param, SCM value)
conv = PARAMETER_CONV(param);
if PARAMETER_C_TYPE(param) {
if (PARAMETER_C_TYPE(param)) {
/* We have a C converter */
new = (conv != STk_false) ? ((SCM (*) (SCM))conv)(value): value;
} else {
......@@ -86,15 +86,18 @@ SCM STk_set_parameter(SCM param, SCM value)
}
tmp = STk_int_assq(STk_current_thread(), PARAMETER_DYNENV(param));
if (tmp != STk_false)
if (tmp != STk_false)
CDR(tmp) = new;
else
PARAMETER_VALUE(param) = new;
else {
if (PARAMETER_C_TYPE(param) != 2)
PARAMETER_VALUE(param) = new;
}
return STk_void;
}
SCM STk_make_C_parameter(SCM symbol, SCM value, SCM (*proc)(SCM new_value))
SCM STk_make_C_parameter(SCM symbol, SCM value, SCM (*proc)(SCM new_value),
SCM module)
{
SCM z;
......@@ -106,14 +109,15 @@ SCM STk_make_C_parameter(SCM symbol, SCM value, SCM (*proc)(SCM new_value))
PARAMETER_DYNENV(z) = STk_nil;
/* Bind it to the given symbol */
STk_define_variable(STk_intern(symbol), z, STk_current_module());
STk_define_variable(STk_intern(symbol), z, module);
return z;
}
SCM STk_make_C_parameter2(SCM symbol, SCM (*value)(void), SCM (*proc)(SCM new_value))
SCM STk_make_C_parameter2(SCM symbol, SCM (*value)(void), SCM (*proc)(SCM new_value),
SCM module)
{
SCM z = STk_make_C_parameter(symbol, (SCM) value, proc);
SCM z = STk_make_C_parameter(symbol, (SCM) value, proc, module);
PARAMETER_C_TYPE(z) = 2;
return z;
......
......@@ -20,7 +20,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: ??-Oct-1993 ??:??
* Last file update: 19-Apr-2007 16:24 (eg)
* Last file update: 22-May-2007 15:30 (eg)
*
*/
......@@ -265,7 +265,7 @@ static SCM read_here_string(SCM port)
{
SCM eof_token = read_token(port, STk_getc(port), TRUE);
SCM res, line;
int ch, first_line = TRUE;
int first_line = TRUE;
if (!SYMBOLP(eof_token)) STk_error("bad symbol for here string ~S", eof_token);
......@@ -864,6 +864,7 @@ int STk_init_reader(void)
/* Declare parameter read-case-sensitve */
STk_make_C_parameter("read-case-sensitive",
MAKE_BOOLEAN(STk_read_case_sensitive),
read_case_sensitive_conv);
read_case_sensitive_conv,
STk_STklos_module);
return TRUE;
}
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 28-Dec-1999 22:58 (eg)
* Last file update: 14-May-2007 11:55 (eg)
* Last file update: 22-May-2007 15:30 (eg)
*/
......@@ -488,6 +488,7 @@ EXTERN_PRIMITIVE("fx+", fxplus, subr2, (SCM o1, SCM o2));
EXTERN_PRIMITIVE("fx-", fxminus, subr2, (SCM o1, SCM o2));
EXTERN_PRIMITIVE("fx*", fxtime, subr2, (SCM o1, SCM o2));
EXTERN_PRIMITIVE("fxdiv", fxdiv, subr2, (SCM o1, SCM o2));
int STk_init_fixnum(void);
/*
......@@ -585,6 +586,15 @@ EXTERN_PRIMITIVE("assoc", assoc, subr2, (SCM obj, SCM alist));
int STk_init_list(void);
/*
------------------------------------------------------------------------------
----
---- M D 5 . C
----
------------------------------------------------------------------------------
*/
int STk_init_md5(void);
/*
------------------------------------------------------------------------------
......@@ -746,8 +756,10 @@ int STk_init_parameter(void);
SCM STk_get_parameter(SCM param);
SCM STk_set_parameter(SCM param, SCM value);
SCM STk_make_C_parameter(SCM symbol, SCM value, SCM (*proc)(SCM new_value));
SCM STk_make_C_parameter2(SCM symbol,SCM (*value)(void),SCM (*proc)(SCM new_value));
SCM STk_make_C_parameter(SCM symbol, SCM value, SCM (*proc)(SCM new_value),
SCM module);
SCM STk_make_C_parameter2(SCM symbol,SCM (*value)(void),SCM (*proc)(SCM new_value),
SCM module);
/*
......@@ -920,6 +932,7 @@ int STk_init_vport(void);
**** port.h primitives
****/
EXTERN_PRIMITIVE("close-port", close_port, subr1, (SCM port));
EXTERN_PRIMITIVE("read-line", read_line, subr01, (SCM port));
void STk_error_bad_port(SCM p);
void STk_error_bad_file_name(SCM f);
......
......@@ -16,7 +16,7 @@
*
* Author: Erick Gallesio [eg@kaolin.unice.fr]
* Creation date: 29-Mar-1994 10:57
* Last file update: 11-May-2007 14:56 (eg)
* Last file update: 23-May-2007 17:26 (eg)
*/
#include <unistd.h>
......@@ -63,11 +63,6 @@ static void error_bad_int_or_out_of_bounds(SCM val)
STk_error("bad integer ~S (or out of range)", val);
}
static void error_cannot_copy(SCM f1, SCM f2)
{
STk_error("cannot copy file ~S to ~S", f1, f2);
}
static void error_win32_primitive(void)
{
STk_error("Win32 primitive not available on this system");
......@@ -96,6 +91,12 @@ static int my_stat(SCM path, struct stat *s)
return stat(STk_expand_file_name(STRING_CHARS(path)), s);
}
static int my_lstat(SCM path, struct stat *s)
{
if (!STRINGP(path)) error_bad_path(path);
return lstat(STk_expand_file_name(STRING_CHARS(path)), s);
}
int STk_dirp(const char *path)
......@@ -429,7 +430,9 @@ DEFINE_PRIMITIVE("file-is-executable?", file_is_executablep, subr1, (SCM f))
DEFINE_PRIMITIVE("file-exists?", file_existsp, subr1, (SCM f))
{
return my_access(f, F_OK);
struct stat info;
return MAKE_BOOLEAN(my_lstat(f, &info) == 0);
}
/*
......
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