Commit b187436f authored by Erick Gallesio's avatar Erick Gallesio

new primitive: SIGNAL-ERROR

parent 6590457b
......@@ -6903,7 +6903,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/ScmPkg.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 pkgman/Makefile"
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/ScmPkg.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/stklos-pkg.1 doc/skb/stklos-version.stk pkgman/Makefile"
cat >confcache <<\_ACEOF
# This file is a shell script that caches the results of configure
......@@ -7531,6 +7531,7 @@ do
"doc/stklos-compile.1") CONFIG_FILES="$CONFIG_FILES doc/stklos-compile.1" ;;
"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/stklos-pkg.1") CONFIG_FILES="$CONFIG_FILES doc/stklos-pkg.1" ;;
"doc/skb/stklos-version.stk") CONFIG_FILES="$CONFIG_FILES doc/skb/stklos-version.stk" ;;
"pkgman/Makefile") CONFIG_FILES="$CONFIG_FILES pkgman/Makefile" ;;
......
......@@ -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: 21-May-2007 14:39 (eg)
dnl Last file update: 30-May-2007 22:43 (eg)
AC_INIT(src/stklos.c)
......@@ -534,7 +534,7 @@ AC_OUTPUT(Makefile src/Makefile src/extraconf.h doc/Makefile
lib/ScmPkg.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/stklos-genlex.1 doc/stklos-install.1 doc/stklos-pkg.1
doc/skb/stklos-version.stk
pkgman/Makefile)
......
......@@ -40,7 +40,7 @@ subdir = doc
DIST_COMMON = $(srcdir)/Makefile.am $(srcdir)/Makefile.in \
$(srcdir)/stklos-compile.1.in $(srcdir)/stklos-config.1.in \
$(srcdir)/stklos-genlex.1.in $(srcdir)/stklos-install.1.in \
$(srcdir)/stklos.1.in TODO
$(srcdir)/stklos-pkg.1.in $(srcdir)/stklos.1.in TODO
ACLOCAL_M4 = $(top_srcdir)/aclocal.m4
am__aclocal_m4_deps = $(top_srcdir)/configure.in
am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \
......@@ -48,7 +48,7 @@ am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \
mkinstalldirs = $(SHELL) $(top_srcdir)/mkinstalldirs
CONFIG_HEADER = $(top_builddir)/src/stklosconf.h
CONFIG_CLEAN_FILES = stklos.1 stklos-config.1 stklos-compile.1 \
stklos-genlex.1 stklos-install.1
stklos-genlex.1 stklos-install.1 stklos-pkg.1
SOURCES =
DIST_SOURCES =
man1dir = $(mandir)/man1
......@@ -253,6 +253,8 @@ stklos-genlex.1: $(top_builddir)/config.status $(srcdir)/stklos-genlex.1.in
cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@
stklos-install.1: $(top_builddir)/config.status $(srcdir)/stklos-install.1.in
cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@
stklos-pkg.1: $(top_builddir)/config.status $(srcdir)/stklos-pkg.1.in
cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@
install-man1: $(man1_MANS) $(man_MANS)
@$(NORMAL_INSTALL)
test -z "$(man1dir)" || $(MKDIR_P) "$(DESTDIR)$(man1dir)"
......
.\" -*- nroff -*-
.\" First parameter, NAME, should be all caps
.\" Second parameter, SECTION, should be 1-8, maybe w/ subsection
.\" other parameters are allowed: see man(7), man(1)
.TH STKLOS-PKG 1 "version @VERSION@"
.\" Please adjust this date whenever revising the manpage.
.\"
.\" Some roff macros, for reference:
.\" .nh disable hyphenation
.\" .hy enable hyphenation
.\" .ad l left justify
.\" .ad b justify to both left and right margins
.\" .nf disable filling
.\" .fi enable filling
.\" .br insert line break
.\" .sp <n> insert n1 empty lines
.\" for manpage-specific macros, see man(7)
.SH NAME
stklos-pkg \- ScmPkg packages management
.SH SYNOPSIS
\fbstklos-pkg\fR [\fIoptions\fR]
.SH DESCRIPTION
The
.B stklos-pkg
command is the general tool for downloading, installing and uninstalling
.B ScmPkg
packages in STklos.
.LP
The first time you use stklos-pkg you must synchronize your local
repository with the ScmPkg server. This is done using the
\fI--setup\fR option. The other options of stklos-pkg are described
below.
.SH OPTIONS
Here are the options available in the version @VERSION@ of
.B stklos.
.IP "--extract package | -e package"
extract the files of \fIpackage\fR (and all its dependencies) and build a
Unix Makefile for compiling the package. The files are extracted in the
directory specified with option \fI--directory\fR (or the current
directory if the option is unused. The generated Makefile offers the
following targets:
.RS
.IP "all"
to build the package dependencies nd the package itself
.IP "test"
to run package tests
.IP "install"
to install the package (and its dependencies) for the current user
.IP " system-install"
to install the package (and its dependencies) system-wide
.RE
.IP "--test=package | -t package"
extract and test the given package in a temporary directory. If the
test succeeds, the \fIstklos-pkg\fR command returns 0.
.IP "--install=package| -i package"
install the given package and its dependencies in the standard
installation directory. If the \fI--system-wide\fR flag is not used, files
are installed in the user directory. Otherwise, files are installed in
a shared directory available to all users.
.IP "--uninstall package"
un-install the files which were copied during the installation of the
given package. Use the \fI--system-wide\fR option to un-install shared files.
.IP "--sync | -s"
synchronize the local repository on the ScmPkg server(s). This will
download the description of all the packages which are available on
the server(s). The packages themselves are downloaded, only when
needed.
.IP "--add=package| -a package"
adds the given package to the repository.
.IP "--fill-cache"
downloads all the package which are available on the server(s). This
can be used for copying all remote packages, when the net connection
is not permanent for instance.
.IP "--clear-cache"
remove all the packages from the cache. This can be used when packages
files take too much place. Packages will be downloaded when needed
.IP "--reset"
remove all the files needed by ScmPkg, that is the cache of packages,
but also the binary of installed packages, their documentation, and
all the meta-data of ScmPkg.
.IP "--list |-l"
list all the packages which are available from server(s) and from the
current repository.
.IP "--depends=package"
list the packages needed by the given package
.IP "--installed"
list the packages which are locally installed
.IP "--directory=dir | -C dir"
Use the specified directory for extracting file. If this option is not
specified, files are extracted in the current directory.
.IP "--verbose | -v"
be more verbose. Several usage of this flag increase the verbosity of
stklos-pkg.
.IP "--system-wide | -S"
flag used to indicate that (un-)installation must be system wide.
.IP "--version |-V"
display the version of \fRstklos-pkg\fR and exit.
.IP "--help | -h"
Show a list of options
.SH "FILES"
.IP "~/.stklos/pkg"
The \fISTklos\fR user ScmPkg repository
.IP "@PREFIX@/lib/stklos/pkg"
The \fISTklos\fR system ScmPkg repository here
.SH "SEE ALSO"
.BR stklos (1)
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 14-Jun-2000 17:24 (eg)
;;;; Last file update: 14-May-2007 10:33 (eg)
;;;; Last file update: 30-May-2007 17:30 (eg)
;;;;
;;
......@@ -1008,6 +1008,26 @@ doc>
(apply format port fmt args))
#|
<doc EXT-SYNTAX declare-new-error
* (declare-new-error name)
*
* TODO
*
doc>
|#
(define-macro (declare-new-error name)
(let ((cond-name (string->symbol (format "&~a" name)))
(predicate (string->symbol (format "&~a?" name)))
(args (gensym)))
`(begin
(define-condition-type ,cond-name &error-message ,predicate)
(define (,name . ,args)
(if (and (not (null? ,args))
(symbol? (car ,args)))
(apply signal-error ,cond-name ,args)
(apply signal-error ,cond-name ',name ,args))))))
#|
<doc EXT exec exec-list
* (exec str)
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 25-May-2007 11:15 (eg)
;;;; Last file update: 29-May-2007 18:23 (eg)
;;;; Last file update: 30-May-2007 18:07 (eg)
;;;;
......@@ -60,7 +60,7 @@
;;; do-copy starts here
;;;
(unless (= (length args) 4)
(error "Bad usage of --cp option. 4 parameters required"))
(error-pkg "Bad usage of --cp option. 4 parameters required"))
(let ((package (car args))
(file (cadr args))
......
......@@ -2,7 +2,7 @@
# Compiler
SCC=stklos-compile
SFLAGS=
SFLAGS=-c
SO=@SO@
SCOMP=@SCOMP@
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 15-Jan-2007 12:10 (eg)
;;;; Last file update: 29-May-2007 18:10 (eg)
;;;; Last file update: 30-May-2007 19:58 (eg)
;;;;
;; ----------------------------------------------------------------------
......@@ -69,11 +69,11 @@
(define (build-install-target targets system-wide?)
(let ((prefix (if system-wide? "system-" ""))
(option (if system-wide? "-S" "")))
(printf "~ainstall: $(OBJ)\n" prefix)
(printf "~ainstall: $(OBJS)\n" prefix)
(for-each (lambda (x)
(let* ((tunedir (make-path x "stklos"))
(let* ((tunedir (make-path dir x "stklos"))
(tuneconf (make-path tunedir "configure"))
(docdir (make-path x "doc"))
(docdir (make-path dir x "doc"))
(obj (format "~a.~a" x
(if (file-exists? tuneconf)
"$(SO)"
......@@ -85,7 +85,6 @@
;; installing the doc files
(for-each
(lambda (d)
(eprintf "x = ~S d = ~s\n" x d)
(printf "\tstklos-pkg ~a --cp ~a ~a doc 0744 && \\\n"
option x (make-path x "doc" d)))
docs)))
......@@ -98,7 +97,7 @@
(let* ((tmpl (make-path (%library-prefix) "etc" "stklos" "Makefile-scmpkg.tmpl"))
(in (open-file tmpl "r")))
(unless in
(error 'write-extract-makefile "cannot open template Makefile (~s)" tmpl))
(error-pkg 'write-extract-makefile "cannot open template Makefile (~s)" tmpl))
(let ((make (port->string in))
(tmp (with-output-to-string
......@@ -171,8 +170,25 @@
(lambda ()
(find-and-extract-package package tmpdir)
(when (> (stklos-pkg-verbosity) 0)
(eprintf "Start Testing package ~S in directory ~S\n" package tmpdir))
(eprintf "Start testing package ~S in directory ~S\n" package tmpdir))
(test-package package tmpdir))
(lambda()
(when (> (stklos-pkg-verbosity) 0)
(eprintf "Deleting build and test directory ~S\n" tmpdir))
(rm-rf tmpdir))))
;; ----------------------------------------------------------------------
;; find-extract-and-install-package ...
;; ----------------------------------------------------------------------
(define (find-extract-and-install-package package tmpdir)
(dynamic-wind
list
(lambda ()
(when (> (stklos-pkg-verbosity) 0)
(eprintf "Start installing package ~S in directory ~S\n" package tmpdir))
(find-and-extract-package package tmpdir)
(install-package package tmpdir))
(lambda()
(when (> (stklos-pkg-verbosity) 0)
(eprintf "Deleting build directory ~S\n" tmpdir))
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 30-May-2007 11:42 (eg)
;;;; Last file update: 30-May-2007 13:01 (eg)
;;;; Last file update: 30-May-2007 19:55 (eg)
;;;;
;; ----------------------------------------------------------------------
......@@ -56,7 +56,10 @@
(for-each remove-file files)
(remove-file filedir)
(eprintf "Package ~a is un-installed\n" package))
(error "package ~a is not installed" package))))
(error-pkg "package ~a is not installed" package))))
;; ----------------------------------------------------------------------
;; install-packages ...
;; ----------------------------------------------------------------------
(define (install-package name dir)
(system (format "cd ~a; make all install" dir)))
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 22-Dec-2006 11:32 (eg)
;;;; Last file update: 30-May-2007 13:13 (eg)
;;;; Last file update: 30-May-2007 23:16 (eg)
;;;;
(include "../lib/http.stk")
......@@ -55,9 +55,24 @@
(set! actions (cons (list 'extract pkg) actions)))
(("test" :arg pkg :alternate "t" :help "Test <pkg>.")
(set! actions (cons (list 'test pkg) actions)))
(("install" :arg pkg :alternate "i" :help "Extract, compile, Install <pkg>.")
(set! actions (cons (list 'install pkg) actions)))
(("uninstall" :arg pkg :help "un-install package <pkg>")
(set! actions (cons (cons 'uninstall pkg) actions)))
"Repository administration"
(("sync" :alternate "s" :help "synchronize with remote server servers")
(set! actions (cons 'sync actions)))
(("add" :alternate "a" :arg sb
:help "Add <sb> pkgball to the local repository")
(set! actions (cons (list 'add sb) actions)))
(("fill-cache" :help "fill cache with available distant packages")
(set! actions (cons 'fill-cache actions)))
(("clear-cache" :help "delete packages present in cache")
(set! actions (cons 'clear-cache actions)))
(("reset" :help "reset stklos-pkg repository. USE WITH CAUTION")
(set! actions (cons 'delete-repo actions)))
"Informations"
(("list" :alternate "l" :help "list available packages")
(set! actions (cons 'list actions)))
......@@ -65,20 +80,8 @@
(set! actions (cons (list 'package-deps pkg) actions)))
(("installed" :help "Show installed packages")
(set! actions (cons 'installed actions)))
"Repository administration"
(("sync" :alternate "s" :help "synchronize with remote server servers")
(set! actions (cons 'sync actions)))
(("delete-repository" :help "delete stklos-pkg repository. USE WITH CAUTION")
(set! actions (cons 'delete-repo actions)))
(("fill-cache" :help "fill the cache with all available packages")
(set! actions (cons 'fill-cache actions)))
(("clear-cache" :help "delete files present in cache")
(set! actions (cons 'clear-cache actions)))
(("add" :alternate "a" :arg sb
:help "Add <sb> pkgball to the local repository")
(set! actions (cons (list 'add sb) actions)))
"Misc"
(("directory" :arg dir :alternate "C"
:help "Change to directory <dir> when extracting")
......@@ -87,15 +90,15 @@
(stklos-pkg-verbosity (+ (stklos-pkg-verbosity) 1)))
(("system-wide" :alternate "S" :help "do a system wide (de)installation")
(stklos-pkg-swide #t))
(("version" :alternate "V" :help "print the version and exit")
(eprintf "stklos-pkg shipped with STklos (version ~A)\n" (version))
(exit 0))
(("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-stklos-pkg shipped with STklos (version ~A)\n" (version))
(exit 0))
(("cp" :help "INTERNAL USE ONLY. Do not use this option")
(set! cp #t))
(else
......@@ -109,25 +112,14 @@
;; ----------------------------------------------------------------------
;; global-handler ...
;; ----------------------------------------------------------------------
(define-macro (declare-new-error name)
(let ((condition-name (string->symbol (format "&~a" name)))
(predicate (string->symbol (format "&~a?" name))))
`(begin
(define-condition-type ,
(declare-new-error error-pkg)
(define-condition-type &error-pkg &error-message foo)
(define (global-handler c)
(if (and (condition? c) (condition-has-type? c &error-message))
(let ((who (condition-ref c 'location))
(msg (condition-ref c 'message)))
(describe c)
(unless (condition-has-type? c &error-pkg)
(describe c))
(format (current-error-port)
"**** ERROR: ~a~a\n"
msg
......@@ -167,6 +159,9 @@
((test)
(exit (find-extract-and-test-package (cadar actions)
(temporary-file-name))))
((install)
(exit (find-extract-and-install-package (cadar actions)
(temporary-file-name))))
((package-deps)
(for-each (lambda (x) (printf "~a\n" x))
(package-deps* (cadar actions))))
......@@ -183,5 +178,5 @@
((uninstall)
(uninstall-package (cdar actions)))
(else (error "bad command ~S" (car actions))))
(else (error-pkg "bad command ~S" (car actions))))
(loop (cdr actions))))))
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 14-Jan-2007 13:37 (eg)
;;;; Last file update: 30-May-2007 11:41 (eg)
;;;; Last file update: 30-May-2007 19:58 (eg)
;;;;
;; ----------------------------------------------------------------------
......@@ -37,7 +37,7 @@
((interface ?- . ?rest) rest)
(else (loop (read e)))))))))
(unless in
(error "Cannot open source file ~S" file))
(error-pkg "Cannot open source file ~S" file))
(let ((res (parse in)))
(close-port in)
res)))
......@@ -143,12 +143,17 @@
;; ----------------------------------------------------------------------
(define (rm-rf path)
(when (file-exists? path)
;(eprintf "rm -rf ~S\n" path)
(if (file-is-directory? path)
(let ((files (cddr (directory-files path))))
;(eprintf "C'est un directory ~S\n" path)
(for-each (lambda (f) (rm-rf (make-path path f)))
files)
;(eprintf "effacer le repertoire lafin ~S\n" path)
(delete-directory path))
(remove-file path))))
(begin
;(eprintf "effacer fichier ~S\n" path)
(remove-file path)))))
;; ----------------------------------------------------------------------
;; untar ...
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 26-Dec-2006 16:23 (eg)
;;;; Last file update: 29-May-2007 18:22 (eg)
;;;; Last file update: 30-May-2007 23:23 (eg)
;;;;
......@@ -29,7 +29,7 @@
(make-parameter (expand-file-name "~/.stklos/pkg")))
(define stklos-pkg-system-directory
(make-parameter (make-path (%library-prefix) "share" "stklos" "pkg")))
(make-parameter (make-path (%library-prefix) "lib" "stklos" "pkg")))
(define stklos-pkg-servers-directory
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 26-Dec-2006 18:20 (eg)
;;;; Last file update: 30-May-2007 11:42 (eg)
;;;; Last file update: 30-May-2007 18:08 (eg)
;;;;
......@@ -40,7 +40,7 @@
(let* ((name (make-path (stklos-pkg-servers-directory) x))
(out (open-file name "w")))
(unless out
(error "cannot create server file ~a" name))
(error-pkg "cannot create server file ~a" name))
(fprintf out ";; Generated file. DO NOT EDIT\n~a\n" '())
(close-port out)))
(server-names)))
......@@ -90,12 +90,12 @@
((tuning ?name . ?options)
(add-tuning name options))
(else
(error "bad package/tuning description ~S" descr))))
(error-pkg "bad package/tuning description ~S" descr))))
(define (add-descriptions src)
(let ((in (open-file src "r")))
(unless in
(error "cannot load description in file ~s" src))
(error-pkg "cannot load description in file ~s" src))
(let ((lst (read in)))
(close-port in)
(unless (eof-object? lst)
......@@ -136,7 +136,7 @@
(let* ((name (make-path (stklos-pkg-servers-directory) server-name))
(out (open-file name "w")))
(unless out
(error "cannot save server descriptions of ~s" server-name))
(error-pkg "cannot save server descriptions of ~s" server-name))
(fprintf out ";; -*- Scheme -*- Generated file DO NOT EDIT\n")
(fprintf out ";; Synchronization of ~a at ~s\n" server-name url)
(fprintf out ";; State saved ~a\n" (date))
......@@ -233,7 +233,7 @@
(let ((lmd5 (md5sum-file path)))
(unless (equal? lmd5 md5)
(remove-file path)
(error "package ~S corrupted. Cache file has been deleted" package)))
(error-pkg "package ~S corrupted. Cache file has been deleted" package)))
;; We have finished
(when (> (stklos-pkg-verbosity) 0)
......
This diff is collapsed.
This source diff could not be displayed because it is too large. You can view the blob instead.
/*
* cond.c -- Condition implementation
*
* Copyright © 2004-2006 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
* Copyright © 2004-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: 22-May-2004 08:57 (eg)
* Last file update: 20-Dec-2006 11:09 (eg)
* Last file update: 30-May-2007 17:18 (eg)
*/
#include "stklos.h"
......@@ -79,6 +79,8 @@ static SCM is_a(SCM type, SCM t)
}
}
/* ----------------------------------------------------------------------
* allocate_condition ...
* ---------------------------------------------------------------------- */
......@@ -195,6 +197,13 @@ SCM STk_defcond_type(char *name, SCM parent, SCM slots, SCM module)
}
SCM STk_condition_type_is_a(SCM type, SCM t)
{
if (!COND_TYPEP(type)) error_bad_type(type);
if (!COND_TYPEP(t)) error_bad_type(t);
return is_a(type, t);
}
/* ======================================================================
*
* C O N D I T I O N S
......
......@@ -22,7 +22,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 14-Nov-1993 14:58
* Last file update: 8-Feb-2007 18:47 (eg)
* Last file update: 30-May-2007 16:27 (eg)
*/
#include "stklos.h"
......@@ -116,11 +116,11 @@ static void print_format(SCM port,char *format, va_list ap)
}
}
void STk_signal_error(SCM where, SCM str)
void STk_signal_error(SCM type, SCM where, SCM str)
{
SCM bt = STk_vm_bt();
STk_raise_exception(STk_make_C_cond(STk_err_mess_condition, 3, where, bt, str));
STk_raise_exception(STk_make_C_cond(type, 3, where, bt, str));
}
SCM STk_format_error(char *format, ...)
......@@ -178,6 +178,8 @@ SCM STk_make_error(char *format, ...)
}
void STk_error(char *format, ...)
{
va_list ap;
......
......@@ -20,7 +20,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 17-Feb-1993 12:27
* Last file update: 15-May-2007 11:38 (eg)
* Last file update: 30-May-2007 17:03 (eg)
*
*/
......@@ -1021,8 +1021,7 @@ static int msg_use_tilde(char *s)
return p ? (p[1] && strchr("aAsSwW~", p[1]) != NULL): 0;
}
DEFINE_PRIMITIVE("error", scheme_error, vsubr, (int argc, SCM *argv))
static SCM do_error(SCM type, int argc, SCM *argv)
{
SCM who = STk_false;
......@@ -1040,14 +1039,50 @@ DEFINE_PRIMITIVE("error", scheme_error, vsubr, (int argc, SCM *argv))
msg = srfi_23_error(argc, argv);
else
msg = internal_format(argc, argv, TRUE);
STk_signal_error(who, msg);
STk_signal_error(type, who, msg);
}
}
STk_signal_error(who, STk_Cstring2string(""));
STk_signal_error(type, who, STk_Cstring2string(""));
return STk_void;
}
DEFINE_PRIMITIVE("error", scheme_error, vsubr, (int argc, SCM *argv))
{
return do_error(STk_err_mess_condition, argc, argv);
}
/*
<doc EXT signal-error
* (signal-error cond str obj ...)
* (signal-error cond name str obj ...)
*
* This procedure is similar to error, except that the type of the error
* can be passed as the first parameter. The type of the error must be a
* condition which inherit from |&error-message|.
*
* Note that |(error arg ...)|s equivalent to
* @lisp
* (signal-error &error-message arg ...)
* @end lisp
doc>
*/
DEFINE_PRIMITIVE("signal-error", scheme_signal_error, vsubr, (int argc, SCM *argv))
{
SCM type_error;
if (! argc) STk_error("error condtion expected");
type_error = *argv;
argc -= 1;
argv -= 1;
if (STk_condition_type_is_a(type_error, STk_err_mess_condition) == STk_false)
STk_error("bad &error-message ~S", type_error);
return do_error(type_error, argc, argv);
}
/*
<doc close-input-port close-output-port
......@@ -1475,6 +1510,7 @@ int STk_init_port(void)
ADD_PRIMITIVE(write_star);
ADD_PRIMITIVE(format);
ADD_PRIMITIVE(scheme_error);
ADD_PRIMITIVE(scheme_signal_error);
ADD_PRIMITIVE(close_input_port);
ADD_PRIMITIVE(close_output_port);
......
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 28-Dec-1999 22:58 (eg)
* Last file update: 22-May-2007 15:30 (eg)
* Last file update: 30-May-2007 17:00 (eg)
*/
......@@ -352,7 +352,7 @@ EXTERN_PRIMITIVE("make-condition-type", make_cond_type, subr3,
(SCM name, SCM parent, SCM slots));
SCM STk_defcond_type(char *name, SCM parent, SCM slots, SCM module);
SCM STk_condition_type_is_a(SCM type, SCM t);
int STk_init_cond(void);
......@@ -387,7 +387,7 @@ SCM STk_info_object_file(char *fname);
------------------------------------------------------------------------------
*/
void STk_signal_error(SCM who, SCM str);
void STk_signal_error(SCM type, SCM who, SCM str);
void STk_error(char *format, ...);
SCM STk_make_error(char *format, ...);
SCM STk_format_error(char *format, ...);
......
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