Commit 9566810d authored by Erick's avatar Erick

.

parents 8bf26020 9e98e7ae
;;;;
;;;; b i g m a t c h . s t k -- The bigloo match-case and match-lambda
;;;;
;;;; Copyright © 1997-2007 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;; Copyright © 1997-2011 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;; Permission to use, copy, modify, distribute,and license this
;;;; software and its documentation for any purpose is hereby granted,
......@@ -14,7 +14,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@kaolin.unice.fr]
;;;; Creation date: 28-Oct-1997 20:47
;;;; Last file update: 25-Apr-2007 23:57 (eg)
;;;; Last file update: 27-Jul-2011 22:49 (eg)
;;;;
;;;; This file implements code for loading the MATCH-CASE and MATCH-LAMBDA
......@@ -76,7 +76,7 @@ doc>
* the result of the last is the result of the whole |match-case|
* expression; otherwise the result of the |match-case| expression
* is unspecified.
* £
* ,(linebreak)
* The equality predicate used for tests is |eq?|.
* @lisp
* (match-case '(a b a)
......
;;;;
;;;; env.stk -- R5RS environments
;;;;
;;;; Copyright © 2006 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
;;;;
;;;;
;;;;
;;;; Copyright © 2006-2011 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,
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 29-Nov-2006 22:33 (eg)
;;;; Last file update: 19-Dec-2006 12:13 (eg)
;;;; Last file update: 27-Jul-2011 22:52 (eg)
;;;;
;;=============================================================================
;; interaction-environment ...
;; interaction-environment ...
;;=============================================================================
#|
<doc interaction-environment
......@@ -37,11 +37,11 @@
doc>
|#
(define (interaction-environment)
(find-module 'STklos))
(find-module 'STklos))
;;=============================================================================
;; null-environment ...
;; null-environment ...
;;=============================================================================
(define-module NULL-MODULE) ;; The module for null-environment
......@@ -57,7 +57,7 @@ doc>
* Returns a specifier for an environment that is empty except for
* the (syntactic) bindings for all syntactic keywords defined in
* the R5RS report.
* £
* ,(linebreak)
* ,(bold "Note"): In STklos, |null-environment| function can be called
* without the version number (defaults to 5).
doc>
......@@ -68,11 +68,11 @@ doc>
(find-module 'NULL-MODULE))
;;=============================================================================
;; scheme-report-environment ...
;; scheme-report-environment ...
;;=============================================================================
(define-module R5RS
(import SCHEME)
(define * *)
(define + +)
(define - -)
......@@ -309,7 +309,7 @@ doc>
*
* Returns a specifier for an environment that contains the bindings defined
* in the R5RS report.
* £
* ,(linebreak)
* ,(bold "Note"): In STklos, |scheme-report-environment| function can be called
* without the version number (defaults to 5).
doc>
......
......@@ -23,7 +23,7 @@
;;;; NATURE WHATSOEVER.
;;;;
;;;; Creation date: 26-Jan-2001 17:49 (eg)
;;;; Last file update: 5-Jun-2002 11:28 (eg)
;;;; Last file update: 27-Jul-2011 22:52 (eg)
;;;;
#|
......@@ -38,12 +38,12 @@
* |syntax-rules|, and |<body>| should be a sequence of one or more expressions. It
* is an error for a |<keyword>| to appear more than once in the list of keywords
* being bound.
*
* ,(linebreak)
* The |<body>| is expanded in the syntactic environment obtained by
* extending the syntactic environment of the |let-syntax| expression with macros
* whose keywords are the |<keyword>|s, bound to the specified transformers. Each
* binding of a |<keyword>| has |<body>| as its region.
*
* ,(linebreak)
* ,(bold "Note:") |let-syntax| is available only after having required the file
* |"full-syntax"|.
* @lisp
......@@ -66,7 +66,7 @@ doc>
* (letrec-syntax <bindings> <body>)
*
* Syntax of |letrec-syntax| is the same as for |let-syntax|.
*
* ,(linebreak)
* The |<body>| is expanded in the syntactic environment obtained by
* extending the syntactic environment of the |letrec-syntax| expression
* with macros whose keywords are the |<keyword>|s, bound to the specified
......@@ -74,7 +74,7 @@ doc>
* as the |<body>| within its region, so the transformers can transcribe
* expressions into uses of the macros introduced by the |letrec-syntax|
* expression.
*
* ,(linebreak)
* ,(bold "Note:") |letrec-syntax| is available only after having required the file
* |"full-syntax"|.
*
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 26-Oct-2001 08:40 (eg)
;;;; Last file update: 27-May-2011 22:50 (eg)
;;;; Last file update: 27-Jul-2011 22:53 (eg)
;;;;
;;;;
......@@ -121,17 +121,17 @@ doc>
* this form internally uses the GNU C |getopt| function. As a
* consequence |parse-arguments| accepts options which start with
* the '-' (short option) or '--' characters (long option).
* £
* ,(linebreak)
* The first argument of |parse-arguments| is a list of the arguments
* given to the program (comprising the program name in the CAR of this
* list). Following arguments are clauses. Clauses are described later.
* £
* ,(linebreak)
* By default, |parse-arguments| permutes the contents of (a copy) of
* the arguments as it scans, so that eventually all the non-options are
* at the end. However, if the shell environment variable |POSIXLY_CORRECT|
* is set, then option processing stops as soon as a non-option argument
* is encountered.
* £
* ,(linebreak)
* A clause must follow the syntax:
* ,(raw-code [
* <clause> => string @pipe <list-clause>
......@@ -151,10 +151,10 @@ doc>
* the option. The |:arg| is used when the option admit a parameter:
* the symbol given after |:arg| will be bound to the value of the option
* argument when the corresponding |<expr>|s will be executed.
* £
* ,(linebreak)
* In an |else| clause the symbol |other-arguments| is bound to the
* list of the arguments which are not options.
* £
* ,(linebreak)
* The following example shows a rather complete usage of the
* |parse-arguments| form
*
......
;;;;
;;;; help.stk -- Interactive help
;;;;
;;;; Copyright © 2009-2010 Erick Gallesio - Polytech'Nice-Sophia <eg@unice.fr>
;;;; Copyright © 2009-2011 Erick Gallesio - Polytech'Nice-Sophia <eg@unice.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
......@@ -25,7 +25,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 20-Dec-2009 18:26 (eg)
;;;; Last file update: 2-Jan-2010 16:55 (eg)
;;;; Last file update: 27-Jul-2011 22:43 (eg)
;;;;
;; ----------------------------------------------------------------------
......@@ -53,7 +53,7 @@
;; ----------------------------------------------------------------------
(define (pretty-doc str)
;; suppress some common Skribe things from the doc string
(set! str (regexp-replace-all "£" str ""))
(set! str (regexp-replace-all ",(linebreak)" str ""))
(set! str (regexp-replace-all "@lisp" str (do-color 'blue)))
(set! str (regexp-replace-all "@end lisp" str (do-color 'normal)))
str)
......
;;;;
;;;; make-C-boot.stk -- Create a C image to boot on
;;;;
;;;; Copyright © 2005-2006 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
;;;;
;;;;
;;;;
;;;; Copyright © 2005-2011 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,
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 29-Mar-2005 14:58 (eg)
;;;; Last file update: 5-Dec-2006 18:50 (eg)
;;;; Last file update: 27-Jul-2011 19:26 (eg)
;;;;
;; ----------------------------------------------------------------------
......@@ -51,15 +51,13 @@ This is a dump of the image in file ~A
(format out "char* STk_boot_consts = ~S;\n\n" (get-output-string str)))
(let ((sz (read in)))
(format out "STk_instr STk_boot_code [] = { \n")
(read-char in) ; To skip the newline after size
(read-byte in) ; To skip the newline after size
(dotimes (i sz)
(let* ((c1 (read-char in))
(c2 (read-char in)))
(let* ((c1 (read-byte in))
(c2 (read-byte in)))
(format out
"0x~A"
(number->string (bit-or (bit-shift (char->integer c1) 8)
(char->integer c2))
16))
(number->string (bit-or (bit-shift c1 8) c2) 16))
(when (< i (- sz 1))
(display ",\n" out))))
(display "};\n" out))
......
;;;;
;;;; regexp.stk -- STklos Regular Expressions
;;;;
;;;; Copyright © 1994-2009 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;;
;;;;
;;;; Copyright © 1994-2011 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.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,
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 9-Nov-1994 13:24 (eg)
;;;; Last file update: 27-Sep-2009 18:55 (eg)
;;;; Last file update: 27-Jul-2011 22:53 (eg)
;;;;
......@@ -36,14 +36,14 @@
* |pattern| is replaced by the |substitution| string. If there is no
* match, |regexp-replace| returns |string| unmodified. Note that the
* given |pattern| could be here either a string or a regular expression.
* £
* If |pattern| contains |\\n| where ,(bold "n") is a digit between 1 and 9,
* ,(linebreak)
* If |pattern| contains |\\n| where ,(bold "n") is a digit between 1 and 9,
* then it is replaced in the substitution with the portion of string that
* matched the ,(bold "n")-th parenthesized subexpression of |pattern|. If
* ,(bold "n") is equal to 0, then it is replaced in |substitution|
* with the portion of |string| that matched |pattern|.
* £
* |Regexp-replace| replaces the first occurrence of |pattern| in |string|.
* ,(linebreak)
* |Regexp-replace| replaces the first occurrence of |pattern| in |string|.
* To replace ,(bold "all") the occurrences of |pattern|, use |regexp-replace-all|.
*
* @lisp
......@@ -93,9 +93,9 @@ doc>
(val (string->number (substring subst index (+ index 1)))))
(if (>= val (length match))
(error 'regexp-replace "cannot match \\~A in model" val)
;; Build a new subst with the current \x remplaced by
;; Build a new subst with the current \x remplaced by
;; its value. Iterate for further \x
(Loop (replace-string subst
(Loop (replace-string subst
(caar pos)
(cadar pos)
(apply substring string
......@@ -112,7 +112,7 @@ doc>
(if match
;; There was a match
(replace-string str
(caar match)
(caar match)
(cadar match)
(replace-submodels str subst match))
;; No match, return the original string
......
......@@ -23,7 +23,7 @@
*
* Author: Erick Gallesio [eg@kaolin.unice.fr]
* Creation date: 23-Oct-1993 21:37
* Last file update: 20-Apr-2011 00:33 (eg)
* Last file update: 27-Jul-2011 22:46 (eg)
*/
#include "stklos.h"
......@@ -135,7 +135,7 @@ doc>
*
* ,(bold "Note:") STklos extends R5RS |eqv?| to take into account
* the keyword type.
* £
* ,(linebreak)
* Here are some examples:
* @lisp
* (eqv? 'a 'a) => #t
......@@ -168,7 +168,7 @@ doc>
* ,(bold "Note:") In fact, the value returned by STklos depends of
* the way code is entered and can yield |#t| in some cases and |#f|
* in others.
* £
* ,(linebreak)
* See R5RS for more details on |eqv?|.
doc>
*/
......@@ -224,7 +224,7 @@ DEFINE_PRIMITIVE("eqv?", eqv, subr2, (SCM x, SCM y))
*
* |Eq?| is similar to |eqv?| except that in some cases it is capable of
* discerning distinctions finer than those detectable by |eqv?|.
* £
* ,(linebreak)
* |Eq?| and |eqv?| are guaranteed to have the same behavior on symbols,
* keywords, booleans, the empty list, pairs, procedures, and non-empty strings
* and vectors. |Eq?|'s behavior on numbers and characters is
......@@ -232,10 +232,10 @@ DEFINE_PRIMITIVE("eqv?", eqv, subr2, (SCM x, SCM y))
* and will return true only when |eqv?| would also return true.
* |Eq?| may also behave differently from |eqv?| on empty vectors
* and empty strings.
* £
* ,(linebreak)
* ,(bold "Note:") STklos extends R5RS |eq?| to take into account
* the keyword type.
* £
* ,(linebreak)
* ,(bold "Note:") In STklos, comparison of character returns |#t| for identical
* characters and |#f| otherwise.
*
......
This diff is collapsed.
......@@ -36,7 +36,7 @@
*
* Author: Erick Gallesio [eg@kaolin.unice.fr]
* Creation date: 17-Jan-1994 17:49
* Last file update: 27-May-2011 22:16 (eg)
* Last file update: 27-Jul-2011 22:48 (eg)
*/
#include "stklos.h"
......@@ -762,9 +762,9 @@ DEFINE_PRIMITIVE("hash-table-delete!", hash_delete, subr2, (SCM ht, SCM key))
* calls |proc| on each key/value association in |hash|, with the key as
* the first argument and the value as the second. The value returned by
* |hash-table-for-each| is ,(emph "void").
* £
* ,(linebreak)
* ,(bold "Note:") The order of application of |proc| is unspecified.
* £
* ,(linebreak)
* ,(bold "Note:") |hash-table-walk| is another name for |hash-table-for-each|
* (this is the name used in ,(link-srfi 69)).
*
......@@ -804,7 +804,7 @@ DEFINE_PRIMITIVE("hash-table-for-each", hash_for_each, subr2, (SCM ht, SCM proc)
* the first argument and the value as the second. The result of
* |hash-table-map| is a list of the values returned by |proc|, in an
* unspecified order.
* £
* ,(linebreak)
* ,(bold "Note:") The order of application of |proc| is unspecified.
* @lisp
* (let ((h (make-hash-table)))
......
......@@ -2,25 +2,25 @@
*
* k e y w o r d . c -- Keywords management
*
* Copyright 1993-2006 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
* Copyright 1993-2011 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.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,
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
* USA.
*
* Author: Erick Gallesio [eg@kaolin.unice.fr]
* Creation date: 19-Nov-1993 16:12
* Last file update: 20-Oct-2006 14:42 (eg)
* Last file update: 27-Jul-2011 22:53 (eg)
*/
#include "stklos.h"
......@@ -51,7 +51,7 @@ static void error_const_cell(SCM x)
static SCM make_uninterned_keyword(char *name)
{
SCM z;
NEWCELL(z, keyword);
SYMBOL_PNAME(z) = name; /* already duplicated in STk_makekey */
BOXED_INFO(z) |= STk_symbol_flags(name);
......@@ -65,10 +65,10 @@ SCM STk_makekey(char *token)
char *s;
MUT_DECL(lck);
/* We accept two kinds of keywords :xy and xy:. In anycase, the value
/* We accept two kinds of keywords :xy and xy:. In anycase, the value
* stored does not contain the ':' char.
*/
if (*token == ':')
if (*token == ':')
s = STk_strdup(token + 1);
else {
int len = strlen(token);
......@@ -82,12 +82,12 @@ SCM STk_makekey(char *token)
MUT_LOCK(lck);
res = STk_hash_intern_symbol(&keyword_table, s, make_uninterned_keyword);
MUT_UNLOCK(lck);
return res;
}
/*===========================================================================*\
*
*
* PRIMITIVES
*
\*===========================================================================*/
......@@ -97,7 +97,7 @@ SCM STk_makekey(char *token)
* (make-keyword s)
*
* Builds a keyword from the given |s|. The parameter |s| must be a symbol
* or a string.
* or a string.
* @lisp
* (make-keyword "test") => :test
* (make-keyword 'test) => :test
......@@ -109,7 +109,7 @@ DEFINE_PRIMITIVE("make-keyword", make_keyword, subr1, (SCM str))
{
char *s = "";
if (STRINGP(str))
if (STRINGP(str))
s = STRING_CHARS(str);
else if (SYMBOLP(str))
s = SYMBOL_PNAME(str);
......@@ -155,7 +155,7 @@ DEFINE_PRIMITIVE("keyword->string", keyword2string, subr1, (SCM obj))
return res;
}
/*
<doc EXT key-get
* (key-get list key)
......@@ -203,13 +203,13 @@ DEFINE_PRIMITIVE("key-get", key_get, subr23, (SCM l, SCM key, SCM dflt))
* (key-set! list key value)
*
* |List| must be a list of keywords and their respective values.
* |key-set!| sets the value associated to |key| in the keyword list.
* If the key is already present in |list|, the keyword list is
* ,(emph "physically") changed.
* |key-set!| sets the value associated to |key| in the keyword list.
* If the key is already present in |list|, the keyword list is
* ,(emph "physically") changed.
* @lisp
* (let ((l (list :one 1 :two 2)))
* (set! l (key-set! l :three 3))
* (cons (key-get l :one)
* (cons (key-get l :one)
* (key-get l :three))) => (1 . 3)
* @end lisp
doc>
......@@ -242,14 +242,14 @@ DEFINE_PRIMITIVE("key-set!", key_set, subr3, (SCM l, SCM key, SCM val))
}
/*
<doc EXT key-delete key-delete!
<doc EXT key-delete key-delete!
* (key-delete list key)
* (key-delete! list key)
*
* |List| must be a list of keywords and their respective values.
* |key-delete| remove the |key| and its associated value of the keyword
* list. The key can be absent of the list.
*
* |key-delete| remove the |key| and its associated value of the keyword
* list. The key can be absent of the list.
* ,(linebreak)
* |key-delete!| does the
* same job than |key-delete| by physically modifying its |list| argument.
* @lisp
......@@ -272,7 +272,7 @@ static SCM key_del(SCM l, SCM key)
if (!KEYWORDP(CAR(l))) error_bad_keyword(CAR(l));
if (strcmp(KEYWORD_PNAME(CAR(l)), KEYWORD_PNAME(key))==0) {
if (BOXED_INFO(l) & CONS_CONST) error_const_cell(l);
if (prev == l)
if (prev == l)
return CDR(CDR(l));
else {
CDR(prev) = CDR(CDR(l));
......@@ -288,7 +288,7 @@ static SCM key_del(SCM l, SCM key)
return STk_void; /* never reached */
}
}
DEFINE_PRIMITIVE("key-delete!", dkey_delete, subr2, (SCM l, SCM key))
{
......
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 30-Apr-2011 19:46 (eg)
* Last file update: 27-Jul-2011 14:49 (eg)
* Last file update: 27-Jul-2011 22:38 (eg)
*/
#include "stklos.h"
......@@ -147,7 +147,11 @@ int STk_utf8_strlen(char *s, int max)
char *end = s + max;
for (len = 0; s < end; len++) {
s += STk_utf8_sequence_length(s);
int sz = STk_utf8_sequence_length(s);
if (sz == UTF8_INCORRECT_SEQUENCE)
STk_error("bad UTF-8 sequence");
s += sz;
}
return len;
}
......@@ -156,8 +160,13 @@ char *STk_utf8_index(char *s, int i, int max) /* return the address of ith char
{
char *end = s + max;
while ((s < end) && i--)
s += STk_utf8_sequence_length(s);
while ((s < end) && i--) {
int sz = STk_utf8_sequence_length(s);
if (sz == UTF8_INCORRECT_SEQUENCE)
STk_error("bad UTF-8 sequence");
s += sz;
}
return s;
}
......
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