src/TeXmacs/progs/kernel/boot/srfi.scm

   1
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3 ;;
   4 ;; MODULE      : srfi.scm
   5 ;; DESCRIPTION : special keywords collected from elsewhere
   6 ;; COPYRIGHT   : [see copyright statement of each SECTION]
   7 ;;
   8 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   9 ;;
  10 ;; This software falls under the GNU general public license version 3 or later.
  11 ;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
  12 ;; in the root directory or <http://www.gnu.org/licenses/gpl-3.0.html>.
  13 ;;
  14 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  15
  16 (texmacs-module (kernel boot srfi))
  17
  18 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  19 ;; SECTION : and-let* special form
  20 ;;
  21 ;; COPYRIGHT : 2001, Free Software Foundation, Inc.
  22 ;; The copyright of the reference implementation of SRFI-2 by Oleg Kiselyov was
  23 ;; assigned to the Free Software Foundation in Feb. 2001. The following
  24 ;; implementation also includes incidental changes by Dale Jordan.
  25 ;; Modified by David Allouche to use TeXmacs syntax-error procedure.
  26 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  27 ;; and-let* is a generalized and: it evaluates a sequence of forms one
  28 ;; after another till the first one that yields #f; the non-#f result
  29 ;; of a form can be bound to a fresh variable and used in the
  30 ;; subsequent forms.
  31 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  32 ;; Please note that Guile version 1.6.0 and higher provide AND-LET* support
  33 ;; but it does not provide as good an error reporting.
  34 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  35
  36 (define-public-macro (and-let* claws . body)
  37   (let* ((new-vars '())
  38          (result (cons 'and '()))
  39          (growth-point result))
  40
  41     (define (andjoin! clause)
  42       (let ((prev-point growth-point)
  43             (clause-cell (cons clause '())))
  44         (set-cdr! growth-point clause-cell)
  45         (set! growth-point clause-cell)))
  46
  47     (if (not (list? claws))
  48         (syntax-error "and-let*" "Bindings are not a list: ~A" claws))
  49     (for-each
  50      (lambda (claw)
  51        (cond
  52         ((symbol? claw)                         ; BOUND-VARIABLE form
  53          (andjoin! claw))
  54         ((and (pair? claw) (null? (cdr claw)))  ; (EXPRESSION) form
  55          (andjoin! (car claw)))
  56         ((and (pair? claw) (symbol? (car claw)) ; (VARIABLE EXPRESSION) form
  57               (pair? (cdr claw)) (null? (cddr claw)))
  58          (let* ((var (car claw))
  59                 (var-cell (cons var '())))
  60            (if (memq var new-vars)
  61                (syntax-error "and-let*"
  62                              "Duplicate variable in bindings: ~A" var))
  63            (set! new-vars (cons var new-vars))
  64            (set-cdr! growth-point `((let (,claw) (and . ,var-cell))))
  65            (set! growth-point var-cell)))
  66         (else
  67          (syntax-error "and-let*" "Ill-formed binding: ~A" claw))))
  68      claws)
  69     (if (not (null? body))
  70         (if (null? (cdr body))
  71             (andjoin! (car body))
  72             (andjoin! `(begin ,@body))))
  73     result))
  74
  75 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  76 ;; SECTION : receive special form (SRFI-8)
  77 ;; COPYRIGHT : 2000, 2001 Free Software Foundation, Inc.
  78 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  79 ;; Copied from guile-1.6.0.
  80
  81 (define-public-macro (receive vars vals . body)
  82   `(call-with-values (lambda () ,vals)
  83      (lambda ,vars ,@body)))
  84
  85 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  86 ;; SECTION : case-lambda special form (SRFI-16)
  87 ;; COPYRIGHT : 2000, 2001 Free Software Foundation, Inc.
  88 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  89 ;; Copied from guile-1.6.0. Author: Martin Grabmueller
  90
  91 (define-public-macro (case-lambda . clauses)
  92
  93   ;; Return the length of the list @var{l}, but allow dotted list.
  94   (define (alength l)
  95     (cond ((null? l) 0)
  96           ((pair? l) (+ 1 (alength (cdr l))))
  97           (else 0)))
  98
  99   ;; Return @code{#t} if @var{l} is a dotted list, @code{#f} if it is a normal
 100   ;; list.
 101   (define (dotted? l)
 102     (cond ((null? l) #f)
 103           ((pair? l) (dotted? (cdr l)))
 104           (else #t)))
 105
 106   ;; Return the expression for accessing the @var{index}th element of the list
 107   ;; called @var{args-name}. If @var{tail?} is true, code for accessing the
 108   ;; list-tail is generated, otherwise for accessing the list element itself.
 109   (define (accessor args-name index tail?)
 110     (if tail?
 111         (case index
 112           ((0) `,args-name)
 113           ((1) `(cdr ,args-name))
 114           ((2) `(cddr ,args-name))
 115           ((3) `(cdddr ,args-name))
 116           ((4) `(cddddr ,args-name))
 117           (else `(list-tail ,args-name ,index)))
 118         (case index
 119           ((0) `(car ,args-name))
 120           ((1) `(cadr ,args-name))
 121           ((2) `(caddr ,args-name))
 122           ((3) `(cadddr ,args-name))
 123           (else `(list-ref ,args-name ,index)))))
 124
 125   ;; Generate the binding lists of the variables of one case-lambda clause.
 126   ;; @var{vars} is the (possibly dotted) list of variables and @var{args-name}
 127   ;; is the generated name used for the argument list.
 128   (define (gen-temps vars args-name)
 129     (let lp ((v vars) (i 0))
 130       (cond ((null? v) '())
 131             ((pair? v)
 132              (cons `(,(car v) ,(accessor args-name i #f))
 133                    (lp (cdr v) (+ i 1))))
 134             (else `((,v ,(accessor args-name i #t)))))))
 135
 136   ;; Generate the cond clauses for each of the clauses of case-lambda,
 137   ;; including the parameter count check, binding of the parameters and the
 138   ;; code of the corresponding body.
 139   (define (gen-clauses l length-name args-name)
 140     (cond ((null? l) (list '(else (error "too few arguments"))))
 141           (else
 142            (cons
 143             `((,(if (dotted? (caar l)) '>= '=)
 144                ,length-name ,(alength (caar l)))
 145               (let ,(gen-temps (caar l) args-name)
 146               ,@(cdar l)))
 147             (gen-clauses (cdr l) length-name args-name)))))
 148
 149   (let ((args-name (gensym))
 150         (length-name (gensym)))
 151     (let ((proc
 152            `(lambda ,args-name
 153               (let ((,length-name (length ,args-name)))
 154                 (cond ,@(gen-clauses clauses length-name args-name))))))
 155       proc)))
 156
 157 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 158 ;; SECTION : curry which is not curry (SRFI-26)
 159 ;; COPYRIGHT : 2000, Free Software Foundation, Inc.
 160 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 161 ;; Copied from GLUG repository. Author: Daniel Skarda <0rfelyus@ucw.cz>
 162
 163 (define-public-macro (cut slot . slots)
 164   (let loop ((slots     (cons slot slots))
 165              (params    '())
 166              (args      '()))
 167     (if (null? slots)
 168         `(lambda ,(reverse! params) ,(reverse! args))
 169         (let ((s          (car slots))
 170               (rest (cdr slots)))
 171           (case s
 172             ((<>)
 173              (let ((var (gensym)))
 174                (loop rest (cons var params) (cons var args))))
 175             ((<...>)
 176              (if (pair? rest)
 177                  (error "<...> not on the end of cut expression"))
 178              (let ((var (gensym)))
 179                `(lambda ,(append! (reverse! params) var)
 180                   (apply ,@(reverse! (cons var args))))))
 181             (else
 182              (loop rest params (cons s args))))))))
 183
 184 (define-public-macro (cute . slots)
 185   (let ((temp
 186          (map (lambda (s) (and (not (memq s '(<> <...>))) (gensym))) slots)))
 187     `(let ,(delq! #f (map (lambda (t s) (and t (list t s))) temp slots))
 188        (cut ,@(map (lambda (t s) (or t s)) temp slots)))))