blob: a65a270312275559039ddd237baea56ef4e98df9 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
|
; text-block.scm - an internal data type for Sassy
; Copyright (C) 2005 Jonathan Kraut
; This library is free software; you can redistribute it and/or
; modify it under the terms of the GNU Lesser General Public
; License as published by the Free Software Foundation; either
; version 2.1 of the License, or (at your option) any later version.
; This library 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
; Lesser General Public License for more details.
; You should have received a copy of the GNU Lesser General Public
; License along with this library; if not, write to the Free Software
; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
; Contact:
; Jonathan Kraut
; 4130 43 ST #C2
; Sunnyside, NY 11104
; jak76@columbia.edu
; see file COPYING in the top of Sassy's distribution directory
; module text-blocks
; import push-stacks srfi-9
; export all
(define-record-type text-block
(make-text-block a b c d e f g) text-block?
(a t-text)
(b t-reloc t-reloc-set!)
(c t-res t-res-set!)
(d t-unres t-unres-set!)
(e t-mark t-mark-set!)
(f t-label t-label-set!)
(g t-env t-env-set!))
(define (push-t-reloc! t i) (t-reloc-set! t (cons i (t-reloc t))))
(define (push-t-res! t i) (t-res-set! t (cons i (t-res t))))
(define (push-t-unres! t i) (t-unres-set! t (cons i (t-unres t))))
(define (push-t-mark! t i) (t-mark-set! t (cons i (t-mark t))))
(define (pop-t-mark! t) (let ((z (t-mark t)))
(if (not (null? z))
(begin (t-mark-set! t (cdr z))
(car z))
#f)))
(define (push-t-label! t i) (t-label-set! t (cons i (t-label t))))
(define (push-t-env! t env) (t-env-set! t (cons env (t-env t))))
(define (t-make) (make-text-block (make-pushup-stack) '() '() '() '() '() '()))
(define (t-save! t)
(let ((restore-text-block (push-stack-save (t-text t)))
(orig-reloc (t-reloc t))
(orig-res (t-res t))
(orig-unres (t-unres t))
(orig-mark (t-mark t))
(orig-label (t-label t))
(orig-env (t-env t)))
(lambda ()
(restore-text-block)
(t-reloc-set! t orig-reloc)
(t-res-set! t orig-res)
(t-unres-set! t orig-unres)
(t-mark-set! t orig-mark)
(t-label-set! t orig-label)
(t-env-set! t orig-env))))
|