IntenseFinance/gnucash
3
0
Fork 0
mirror of https://github.com/Gnucash/gnucash.git synced 2024-11-23 01:16:43 -06:00
Code Issues Packages Projects Releases Wiki Activity

* lib/srfi/srfi-2.scm: new file.

Browse Source 
* lib/srfi/srfi-9.scm: new file.

* lib/srfi/srfi-11.scm: new file.

* lib/srfi/srfi-8.scm: moved from src/scm/srfi/.

* lib/srfi/srfi-19.scm: moved from src/scm/srfi.

* lib/srfi/README: moved from src/scm/srfi/.

* lib/srfi/srfi-1.scm: moved from src/scm/srfi/.


git-svn-id: svn+ssh://svn.gnucash.org/repo/gnucash/trunk@4200 57a11ea4-9604-0410-9ed3-97b8803252fd
This commit is contained in:
Rob Browning 2001-05-15 15:48:44 +00:00
parent 73c08b34fd
commit 73735fe869
9 changed files with 3610 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
lib/srfi/.cvsignore Normal file
View File

@ -0,0 +1,2 @@
Makefile
Makefile.in

13
lib/srfi/Makefile.am Normal file
View File

@ -0,0 +1,13 @@
gncscmdir = ${GNC_SHAREDIR}/guile-modules/srfi
gncscm_DATA = \
srfi-1.scm \
srfi-2.scm \
srfi-8.scm \
srfi-9.scm \
srfi-11.scm \
srfi-19.scm
EXTRA_DIST = README .cvsignore ${gncscm_DATA}

13
lib/srfi/README Normal file
View File

@ -0,0 +1,13 @@
These files implement various useful SRFIs for Guile. See
http://srfi.schemers.org/. The bits taken from the Guile source tree
will go away whenever gnucash updates to require a more recent version
of Guile.
Sources of files:
srfi-1.scm: Guile translation of reference implementation by Olin Shivers.
srfi-2.scm: Guile source tree (modified for versioning).
srfi-8.scm: Guile source tree (modified for versioning).
srfi-9.scm: Guile source tree (modified for versioning).
srfi-19.scm: Guile source tree (modified for versioning).

1660
lib/srfi/srfi-1.scm Normal file
View File

File diff suppressed because it is too large Load Diff

234
lib/srfi/srfi-11.scm Normal file
View File

@ -0,0 +1,234 @@
;;;; srfi-11.scm --- SRFI-11 procedures for Guile
;;; Copyright (C) 2000 Free Software Foundation, Inc.
;;;
;;; 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, 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 software; see the file COPYING. If not, write to
;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;;; Boston, MA 02111-1307 USA
(define-module (srfi srfi-11)
:use-module (ice-9 syncase))
(export-syntax let-values let*-values)
;;;;;;;;;;;;;;
;; let-values
;;
;; Current approach is to translate
;;
;; (let-values (((x y . z) (foo a b))
;; ((p q) (bar c)))
;; (baz x y z p q))
;;
;; into
;;
;; (call-with-values (lambda () (foo a b))
;; (lambda (<tmp-x> <tmp-y> . <tmp-z>)
;; (call-with-values (lambda () (bar c))
;; (lambda (<tmp-p> <tmp-q>)
;; (let ((x <tmp-x>)
;; (y <tmp-y>)
;; (z <tmp-z>)
;; (p <tmp-p>)
;; (q <tmp-q>))
;; (baz x y z p q))))))
;; I originally wrote this as a define-macro, but then I found out
;; that guile's gensym/gentemp was broken, so I tried rewriting it as
;; a syntax-rules statement.
;;
;; Since syntax-rules didn't seem powerful enough to implement
;; let-values in one definition without exposing illegal syntax (or
;; perhaps my brain's just not powerful enough :>). I tried writing
;; it using a private helper, but that didn't work because the
;; let-values expands outside the scope of this module. I wonder why
;; syntax-rules wasn't designed to allow "private" patterns or
;; similar...
;;
;; So in the end, I dumped the syntax-rules implementation, reproduced
;; here for posterity, and went with the define-macro one below --
;; gensym/gentemp's got to be fixed anyhow...
;
; (define-syntax let-values-helper
; (syntax-rules ()
; ;; Take the vars from one let binding (i.e. the (x y z) from ((x y
; ;; z) (values 1 2 3)) and turn it in to the corresponding (lambda
; ;; (<tmp-x> <tmp-y> <tmp-z>) ...) from above, keeping track of the
; ;; temps you create so you can use them later...
; ;;
; ;; I really don't fully understand why the (var-1 var-1) trick
; ;; works below, but basically, when all those (x x) bindings show
; ;; up in the final "let", syntax-rules forces a renaming.
; ((_ "consumer" () lambda-tmps final-let-bindings lv-bindings
; body ...)
; (lambda lambda-tmps
; (let-values-helper "cwv" lv-bindings final-let-bindings body ...)))
; ((_ "consumer" (var-1 var-2 ...) (lambda-tmp ...) final-let-bindings lv-bindings
; body ...)
; (let-values-helper "consumer"
; (var-2 ...)
; (lambda-tmp ... var-1)
; ((var-1 var-1) . final-let-bindings)
; lv-bindings
; body ...))
; ((_ "cwv" () final-let-bindings body ...)
; (let final-let-bindings
; body ...))
; ((_ "cwv" ((vars-1 binding-1) other-bindings ...) final-let-bindings
; body ...)
; (call-with-values (lambda () binding-1)
; (let-values-helper "consumer"
; vars-1
; ()
; final-let-bindings
; (other-bindings ...)
; body ...)))))
;
; (define-syntax let-values
; (syntax-rules ()
; ((let-values () body ...)
; (begin body ...))
; ((let-values (binding ...) body ...)
; (let-values-helper "cwv" (binding ...) () body ...))))
;
;
; (define-syntax let-values
; (letrec-syntax ((build-consumer
; ;; Take the vars from one let binding (i.e. the (x
; ;; y z) from ((x y z) (values 1 2 3)) and turn it
; ;; in to the corresponding (lambda (<tmp-x> <tmp-y>
; ;; <tmp-z>) ...) from above.
; (syntax-rules ()
; ((_ () new-tmps tmp-vars () body ...)
; (lambda new-tmps
; body ...))
; ((_ () new-tmps tmp-vars vars body ...)
; (lambda new-tmps
; (lv-builder vars tmp-vars body ...)))
; ((_ (var-1 var-2 ...) new-tmps tmp-vars vars body ...)
; (build-consumer (var-2 ...)
; (tmp-1 . new-tmps)
; ((var-1 tmp-1) . tmp-vars)
; bindings
; body ...))))
; (lv-builder
; (syntax-rules ()
; ((_ () tmp-vars body ...)
; (let tmp-vars
; body ...))
; ((_ ((vars-1 binding-1) (vars-2 binding-2) ...)
; tmp-vars
; body ...)
; (call-with-values (lambda () binding-1)
; (build-consumer vars-1
; ()
; tmp-vars
; ((vars-2 binding-2) ...)
; body ...))))))
;
; (syntax-rules ()
; ((_ () body ...)
; (begin body ...))
; ((_ ((vars binding) ...) body ...)
; (lv-builder ((vars binding) ...) () body ...)))))
;; FIXME: This is currently somewhat unsafe (b/c gentemp/gensym is
;; broken -- right now (as of 1.4.1, it doesn't generate unique
;; symbols)
(define-macro (let-values vars . body)
(define (map-1-dot proc elts)
;; map over one optionally dotted (a b c . d) list, producing an
;; optionally dotted result.
(cond
((null? elts) '())
((pair? elts) (cons (proc (car elts)) (map-1-dot proc (cdr elts))))
(else (proc elts))))
(define (undot-list lst)
;; produce a non-dotted list from a possibly dotted list.
(cond
((null? lst) '())
((pair? lst) (cons (car lst) (undot-list (cdr lst))))
(else (list lst))))
(define (let-values-helper vars body prev-let-vars)
(let* ((var-binding (car vars))
(new-tmps (map-1-dot (lambda (sym) (gentemp))
(car var-binding)))
(let-vars (map (lambda (sym tmp) (list sym tmp))
(undot-list (car var-binding))
(undot-list new-tmps))))
(if (null? (cdr vars))
`(call-with-values (lambda () ,(cadr var-binding))
(lambda ,new-tmps
(let ,(apply append let-vars prev-let-vars)
,@body)))
`(call-with-values (lambda () ,(cadr var-binding))
(lambda ,new-tmps
,(let-values-helper (cdr vars) body
(cons let-vars prev-let-vars)))))))
(if (null? vars)
`(begin ,@body)
(let-values-helper vars body '())))
;;;;;;;;;;;;;;
;; let*-values
;;
;; Current approach is to translate
;;
;; (let*-values (((x y z) (foo a b))
;; ((p q) (bar c)))
;; (baz x y z p q))
;;
;; into
;;
;; (call-with-values (lambda () (foo a b))
;; (lambda (x y z)
;; (call-with-values (lambda (bar c))
;; (lambda (p q)
;; (baz x y z p q)))))
(define-syntax let*-values
(syntax-rules ()
((let*-values () body ...)
(begin body ...))
((let*-values ((vars-1 binding-1) (vars-2 binding-2) ...) body ...)
(call-with-values (lambda () binding-1)
(lambda vars-1
(let*-values ((vars-2 binding-2) ...)
body ...))))))
; Alternate define-macro implementation...
;
; (define-macro (let*-values vars . body)
; (define (let-values-helper vars body)
; (let ((var-binding (car vars)))
; (if (null? (cdr vars))
; `(call-with-values (lambda () ,(cadr var-binding))
; (lambda ,(car var-binding)
; ,@body))
; `(call-with-values (lambda () ,(cadr var-binding))
; (lambda ,(car var-binding)
; ,(let-values-helper (cdr vars) body))))))
; (if (null? vars)
; `(begin ,@body)
; (let-values-helper vars body)))

1492
lib/srfi/srfi-19.scm Normal file
View File

File diff suppressed because it is too large Load Diff

62
lib/srfi/srfi-2.scm Normal file
View File

@ -0,0 +1,62 @@
;;;; srfi-2.scm --- SRFI-2 procedures for Guile
;;;;
;;;; Copyright (C) 2001 Free Software Foundation, Inc.
;;;;
;;;; 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, 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 software; see the file COPYING. If not, write to
;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;;;; Boston, MA 02111-1307 USA
(define-module (srfi srfi-2))
(cond
((or (string=? "1.3.4" (version))
(string=? "1.4" (version)))
(use-modules (ice-9 and-let*)))
((string=? "1.3" (version))
(defmacro and-let* (vars . body)
(define (expand vars body)
(cond
((null? vars)
`(begin ,@body))
((pair? vars)
(let ((exp (car vars)))
(cond
((pair? exp)
(cond
((null? (cdr exp))
`(and ,(car exp) ,(expand (cdr vars) body)))
(else
(let ((var (car exp))
(val (cadr exp)))
`(let (,exp)
(and ,var ,(expand (cdr vars) body)))))))
(else
`(and ,exp ,(expand (cdr vars) body))))))
(else
(error "not a proper list" vars))))
(expand vars body)))
(else
(let ((msg
(string-append
"Loaded gnucash srfi-2.scm in unknown Guile version:" (version) ".\n"
"If you're running a Guile newer than 1.4, then this file should\n"
"not have been installed. Please report the bug.")))
(error msg))))
(export-syntax and-let*)

45
lib/srfi/srfi-8.scm Normal file
View File

@ -0,0 +1,45 @@
;;;; srfi-8.scm --- SRFI-8 procedures for Guile
;;; Copyright (C) 2000 Free Software Foundation, Inc.
;;;
;;; 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, 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 software; see the file COPYING. If not, write to
;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;;; Boston, MA 02111-1307 USA
(define-module (srfi srfi-8))
(cond
((or (string=? "1.3" (version))
(string=? "1.3.4" (version))
(string=? "1.4" (version)))
(use-modules (ice-9 slib))
(require 'macro-by-example)
(require 'values)
(define-syntax receive
(syntax-rules ()
((receive formals expression body ...)
(call-with-values (lambda () expression)
(lambda formals body ...))))))
(else
(let ((msg
(string-append
"Loaded gnucash srfi-8.scm in unknown Guile version:" (version) ".\n"
"If you're running a Guile newer than 1.4, then this file should\n"
"not have been installed. Please report the bug.")))
(error msg))))
(export-syntax receive)

89
lib/srfi/srfi-9.scm Normal file
View File

@ -0,0 +1,89 @@
;;;; srfi-9.scm --- SRFI-9 procedures for Guile
;;;;
;;;; Copyright (C) 2001 Free Software Foundation, Inc.
;;;;
;;;; 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, 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 software; see the file COPYING. If not, write to
;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;;;; Boston, MA 02111-1307 USA
;;; Commentary:
;;; This module exports the syntactic form `define-record-type', which
;;; is the means for creating record types defined in SRFI-9.
;;;
;;; The syntax of a record type definition is:
;;;
;;; <record type definition>
;;; -> (define-record-type <type name>
;;; (<constructor name> <field tag> ...)
;;; <predicate name>
;;; <field spec> ...)
;;;
;;; <field spec> -> (<field tag> <accessor name>)
;;; -> (<field tag> <accessor name> <modifier name>)
;;;
;;; <field tag> -> <identifier>
;;; <... name> -> <identifier>
;;;
;;; Usage example:
;;;
;;; guile> (use-modules (srfi srfi-9))
;;; guile> (define-record-type :foo (make-foo x) foo?
;;; (x get-x) (y get-y set-y!))
;;; guile> (define f (make-foo 1))
;;; guile> f
;;; #<:foo x: 1 y: #f>
;;; guile> (get-x f)
;;; 1
;;; guile> (set-y! f 2)
;;; 2
;;; guile> (get-y f)
;;; 2
;;; guile> f
;;; #<:foo x: 1 y: 2>
;;; guile> (foo? f)
;;; #t
;;; guile> (foo? 1)
;;; #f
;;; Code:
(define-module (srfi srfi-9))
(export-syntax define-record-type)
(define-macro (define-record-type type-name constructor/field-tag
predicate-name . field-specs)
`(begin
(define ,type-name
(make-record-type ',type-name ',(map car field-specs)))
(define ,(car constructor/field-tag)
(record-constructor ,type-name ',(cdr constructor/field-tag)))
(define ,predicate-name
(record-predicate ,type-name))
,@(map
(lambda (spec)
(cond
((= (length spec) 2)
`(define ,(cadr spec)
(record-accessor ,type-name ',(car spec))))
((= (length spec) 3)
`(begin
(define ,(cadr spec)
(record-accessor ,type-name ',(car spec)))
(define ,(caddr spec)
(record-modifier ,type-name ',(car spec)))))
(else
(error "invalid field spec " spec))))
field-specs)))