Commit 63cf8133 authored by Erick's avatar Erick

Code cleaning in R7RS strings

parent f5fbab50
;; ======================================================================
;;
;; STklos Reference Manual
;; STklos Reference Manual
;;
;; 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
......@@ -18,13 +18,13 @@
;; USA.
;; Author: Erick Gallesio [eg@unice.fr]
;; Creation date: 26-Nov-2000 18:19 (eg)
;; Last file update: 31-Dec-2011 15:16 (eg)
;; Last file update: 28-Jun-2018 10:47 (eg)
;;
;; ======================================================================
;; ======================================================================
;;
;; Standard Procedures
;; Standard Procedures
;;
;; ======================================================================
(chapter :title "Standard Procedures"
......@@ -239,9 +239,9 @@ which is also shown in this table.])
(p [,(stklos) supports the complete Unicode character set, if UTF-8 encoding is used. Hereafter, are some examples of characters:])
(fontified-code [
#\A ,(symbol-arrow) uppercase A
#\a ,(symbol-arrow) lowercase a
#\x41\; ,(symbol-arrow) the U+0041 character (uppercase A)
#\A ,(symbol-arrow) uppercase A
#\a ,(symbol-arrow) lowercase a
#\x41\; ,(symbol-arrow) the U+0041 character (uppercase A)
#\x03BB\; ,(symbol-arrow) ,(symbol "lambda")
])
......@@ -268,29 +268,29 @@ the following table.])
(table :rules 'cols :frame 'border
(tr :bg "#eeeeee" (th "Sequence") (th "Character inserted"))
(tr (td "\\a")
(td "Alarm"))
(td "Alarm"))
(tr (td "\\b")
(td "Backspace"))
(td "Backspace"))
(tr (td "\\e")
(td " Escape"))
(td " Escape"))
(tr (td "\\n")
(td " Newline"))
(td " Newline"))
(tr (td "\\t")
(td " Horizontal Tab"))
(td " Horizontal Tab"))
(tr (td "\\r")
(td " Carriage Return"))
(td " Carriage Return"))
(tr (td "\\\"")
(td " doublequote U+0022"))
(td " doublequote U+0022"))
(tr (td "\\\\")
(td " backslash U+005C"))
(td " backslash U+005C"))
(tr (td "\\0abc")
(td " ASCII character with octal value abc"))
(td " ASCII character with octal value abc"))
(tr (td "\\x<hexa value>;")
(td " ASCII character with given hexadecimal value"))
(td " ASCII character with given hexadecimal value"))
(tr (td "\\<intraline whitespace><newline><intraline whitespace>")
(td " None (permits to enter a string on several lines)"))
(td " None (permits to enter a string on several lines)"))
(tr (td "\\<other>")
(td " <other>"))))
(td " <other>"))))
(p [For instance, the string])
(fontified-code ["ab\\040\\x20;c\\nd\
e"])
......@@ -321,6 +321,7 @@ legibility.])))
(insertdoc 'string-append)
(insertdoc 'list->string)
(insertdoc 'string-copy)
(insertdoc 'string-copy!)
(insertdoc 'string-split)
(insertdoc 'string-index)
(insertdoc 'string-find?)
......
This diff is collapsed.
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 17-Apr-2011 19:36 (eg)
;;;; Last file update: 28-Jun-2018 17:27 (eg)
;;;; Last file update: 29-Jun-2018 12:19 (eg)
;;;;
;;;; ----------------------------------------------------------------------
......@@ -81,11 +81,9 @@ doc>
(let ((s->l string->list)) ;; s->l is the R5RS function
(set! string->list
(lambda (str :optional (start 0 start?) (end 0 end?))
(if (or start? end?)
(if start?
(let ((end (if end? end (string-length str))))
(with-handler (lambda (x)
(error 'string->list
(condition-ref x 'message)))
(%claim-error 'string->list
(s->l (substring str start end))))
(s->l str))))
(%set-procedure-name! string->list 'string->list))
......@@ -144,7 +142,7 @@ doc>
(err "not enough room in destination string ~S" to))
;; do the copy
(with-handler (lambda (x) (err (condition-ref x 'message)))
(%claim-error 'string-copy!
(%string-copy! to at from start end))))
;;
......@@ -155,24 +153,23 @@ doc>
(define %string-fill2! string-fill!)
;; Implement the one with 2 to 4 parameters
(let ((fill (lambda (str char :optional (start 0 start?) (end 0 end?))
(with-handler (lambda (x) (error 'string-fill! (condition-ref x 'message)))
(if start?
;; R7RS string-fill!
(begin
(unless end?
(set! end (string-length str)))
(let Loop ((i start))
(when (< i end)
(string-set! str i char)
(Loop (+ i 1)))))
;; R5RS string-fill!
(%string-fill2! str char))))))
(%claim-error
'string-fill!
(if start?
;; R7RS string-fill!
(begin
(unless end?
(set! end (string-length str)))
(let Loop ((i start))
(when (< i end)
(string-set! str i char)
(Loop (+ i 1)))))
;; R5RS string-fill!
(%string-fill2! str char))))))
(set! string-fill! fill)
(%set-procedure-name! string-fill! 'string-fill!))
;;;; ----------------------------------------------------------------------
;;;; 6.8 Vectors
;;;; ----------------------------------------------------------------------
......
;;;;
;;;; runtime.stk -- Stuff necessary for bootstaping the system
;;;; runtime.stk -- Stuff necessary for bootstaping the system
;;;;
;;;; Copyright © 2001-2010 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;; Copyright © 2001-2018 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
......@@ -21,19 +21,19 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 15-Mar-2001 22:49 (eg)
;;;; Last file update: 28-Oct-2010 15:18 (eg)
;;;; Last file update: 29-Jun-2018 12:16 (eg)
;;;;
(define (map* fn . l) ; A map which accepts dotted lists (arg lists
(cond ; must be "isomorph"
(define (map* fn . l) ; A map which accepts dotted lists (arg lists
(cond ; must be "isomorph"
((null? (car l)) '())
((pair? (car l)) (cons (apply fn (map car l))
(apply map* fn (map cdr l))))
(apply map* fn (map cdr l))))
(else (apply fn l))))
(define (for-each* fn . l) ; A for-each which accepts dotted lists (arg lists
(cond ; must be "isomorph"
(define (for-each* fn . l) ; A for-each which accepts dotted lists (arg lists
(cond ; must be "isomorph"
((null? (car l)) '())
((pair? (car l)) (apply fn (map car l)) (apply for-each* fn (map cdr l)))
(else (apply fn l))))
......@@ -41,10 +41,10 @@
(define (filter-map func . args)
(filter (lambda (x) x)
(apply map func args)))
(apply map func args)))
#| example
(filter-map (lambda (x) (and (number? x) (+ x 1)))
'(1 2 foo "bar" 7))
'(1 2 foo "bar" 7))
|#
......@@ -57,14 +57,15 @@
(define (symbol-append . args)
(let loop ((args args)
(res ""))
(res ""))
(if (null? args)
(string->symbol res)
(loop (cdr args)
(string-append res (format "~a" (car args)))))))
(string->symbol res)
(loop (cdr args)
(string-append res (format "~a" (car args)))))))
;; ----------------------------------------------------------------------
;; parameters
;; parameters
;; ----------------------------------------------------------------------
#|
<doc EXT stklos-debug-level
......@@ -80,12 +81,12 @@ doc>
(make-parameter 0))
;; ----------------------------------------------------------------------
;; *%system-state-plist* ...
;; *%system-state-plist* ...
;; ----------------------------------------------------------------------
(define *%system-state-plist* (list :name "STklos"))
;; ----------------------------------------------------------------------
;; management of globals ...
;; management of globals ...
;; ----------------------------------------------------------------------
;; This should be in compiler module but it a nightmare with bootstrap.
(define compiler-known-globals
......@@ -100,12 +101,12 @@ doc>
;;; ----------------------------------------------------------------------
;;;
;;; E x p a n d e r s
;;; E x p a n d e r s
;;;
;;; ----------------------------------------------------------------------
(define *expander-list* '()) ; the macros
(define *expander-list-src* '()) ; their source code
(define *expander-published* '()) ; names of the macro to "publish"
(define *expander-list* '()) ; the macros
(define *expander-list-src* '()) ; their source code
(define *expander-published* '()) ; names of the macro to "publish"
(define (expander? x)
(assq x *expander-list*))
......@@ -117,12 +118,12 @@ doc>
(define (initial-expander x e)
(cond
((not (pair? x)) x)
((not (pair? x)) x)
((not (symbol? (car x))) (application-expander x e))
(else (let ((functor (car x)))
(cond
((expander? functor) ((cdr (assq functor *expander-list*)) x e))
(else (application-expander x e)))))))
(cond
((expander? functor) ((cdr (assq functor *expander-list*)) x e))
(else (application-expander x e)))))))
(define (install-expander! id proc code)
......@@ -145,14 +146,14 @@ doc>
(define (delete-expander! id)
(let loop ((lst *expander-list*)
(prv #f))
(prv #f))
(cond
((null? lst)
(void))
((eq? (caar lst) id)
(if prv
(set-cdr! prv (cdr lst))
(set! *expander-list* (cdr lst))))
(set-cdr! prv (cdr lst))
(set! *expander-list* (cdr lst))))
(else
(loop (cdr lst) lst)))))
......@@ -166,16 +167,16 @@ doc>
(define (expander-published-sources)
(let ((warning (in-module |STKLOS-COMPILER| compiler-warning)))
(let Loop ((lst *expander-published*)
(res '()))
(res '()))
(if (null? lst)
(reverse! res)
(let ((mac (assoc (car lst) *expander-list-src*)))
(if mac
(Loop (cdr lst) (cons mac res))
(begin
(warning (void) 'export-syntax
"cannot find source of syntax named ~S" (car lst))
(Loop (cdr lst) res))))))))
(reverse! res)
(let ((mac (assoc (car lst) *expander-list-src*)))
(if mac
(Loop (cdr lst) (cons mac res))
(begin
(warning (void) 'export-syntax
"cannot find source of syntax named ~S" (car lst))
(Loop (cdr lst) res))))))))
(define (expander-published-add! name)
(unless (memq name *expander-published*)
......@@ -198,10 +199,29 @@ doc>
;; ======================================================================
(define %macro-expand*
(let ((expand (lambda (x)
;; as macro-expand without syntax expand (used by full-syntax)
(initial-expander x (lambda (x e) x)))))
;; as macro-expand without syntax expand (used by full-syntax)
(initial-expander x (lambda (x e) x)))))
(lambda (exp)
(let ((new (expand exp)))
(if (equal? new exp)
new
(%macro-expand* new))))))
(if (equal? new exp)
new
(%macro-expand* new))))))
;; ======================================================================
;;
;; %claim-error
;;
;; Permit to claim that a function as detected an error
;; For instance
;; (define (change-first-char! str char)
;; (%claim-error 'change-first-char! (string-set! str 0 char)))
;; > (change-first-char! (string-copy "abc") 10)
;; **** Error:
;; change-first-char!: bad character `10'
;;
;; Here the error is claimed by change-first-char! instead of string-set!
(define-macro (%claim-error owner . body)
(let ((x (gensym)))
`(with-handler (lambda (,x) (error ,owner (condition-ref ,x 'message)))
,@body)))
This diff is collapsed.
This source diff could not be displayed because it is too large. You can view the blob instead.
......@@ -22,7 +22,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: ??????
* Last file update: 28-Jun-2018 17:01 (eg)
* Last file update: 29-Jun-2018 12:26 (eg)
*/
#include <ctype.h>
......@@ -234,7 +234,7 @@ static void copy_array(uint32_t *buff, int len, char* from)
static SCM make_substring(SCM string, long from, long to)
{
/* from and to must be checked bay caller */
/* WARNING: from and to must be checked by caller */
if (STRING_MONOBYTE(string))
return STk_makestring(to - from, STRING_CHARS(string)+from);
else {
......
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