← Back to branch summary

~ubuntu-branches/ubuntu/trusty/librep/trusty

« back to all changes in this revision

Viewing changes to lisp/rep/vm/compiler/lap.jl

  • Committer: Bazaar Package Importer
  • Author(s): Christian Marillat
  • Date: 2001-11-13 15:06:22 UTC
  • Revision ID: james.westby@ubuntu.com-20011113150622-vgmgmk6srj3kldr3
Tags: upstream-0.15.2
Import upstream version 0.15.2

Show diffs side-by-side

added added

removed removed

Lines of Context:
lisp/rep/vm/compiler/lap.jl
 
1
#| lap.jl -- intermediate code management
 
2
 
 
3
   $Id: lap.jl,v 1.6 2000/08/13 19:18:24 john Exp $
 
4
 
 
5
   Copyright (C) 2000 John Harper <john@dcs.warwick.ac.uk>
 
6
 
 
7
   This file is part of librep.
 
8
 
 
9
   librep is free software; you can redistribute it and/or modify it
 
10
   under the terms of the GNU General Public License as published by
 
11
   the Free Software Foundation; either version 2, or (at your option)
 
12
   any later version.
 
13
 
 
14
   librep is distributed in the hope that it will be useful, but
 
15
   WITHOUT ANY WARRANTY; without even the implied warranty of
 
16
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 
17
   GNU General Public License for more details.
 
18
 
 
19
   You should have received a copy of the GNU General Public License
 
20
   along with librep; see the file COPYING.  If not, write to
 
21
   the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
 
22
|#
 
23
 
 
24
(declare (unsafe-for-call/cc))
 
25
 
 
26
(define-structure rep.vm.compiler.lap
 
27
 
 
28
    (export intermediate-code
 
29
            emit-insn
 
30
            make-label
 
31
            push-label-addr
 
32
            fix-label
 
33
            prefix-label
 
34
            push-state
 
35
            pop-state
 
36
            reload-state
 
37
            saved-state)
 
38
 
 
39
    (open rep
 
40
          rep.vm.compiler.utils
 
41
          rep.vm.compiler.bindings)
 
42
 
 
43
  (define saved-state (make-fluid))
 
44
 
 
45
  ;; list of (INSN . [ARG]), (TAG . REFS)
 
46
  (define intermediate-code (make-fluid '()))
 
47
 
 
48
  ;; Output one opcode and its optional argument
 
49
  (define (emit-insn insn)
 
50
    (when (consp insn)
 
51
      ;; so the peepholer can safely modify code
 
52
      (setq insn (copy-sequence insn)))
 
53
    (fluid-set intermediate-code (cons insn (fluid intermediate-code))))
 
54
 
 
55
  ;; Create a new label
 
56
  (define make-label gensym)
 
57
 
 
58
  ;; Arrange for the address of LABEL to be pushed onto the stack
 
59
  (define (push-label-addr label)
 
60
    (emit-insn `(push-label ,label))
 
61
    (increment-stack))
 
62
 
 
63
  ;; Set the address of the label LABEL to the current pc
 
64
  (define fix-label emit-insn)
 
65
 
 
66
  (define (prefix-label label)
 
67
    (fluid-set intermediate-code (nconc (list label)
 
68
                                        (fluid intermediate-code))))
 
69
 
 
70
  (define (push-state)
 
71
    (fluid-set saved-state
 
72
               (cons (list (cons intermediate-code (fluid intermediate-code))
 
73
                           (cons spec-bindings (fluid spec-bindings))
 
74
                           (cons lex-bindings
 
75
                                 (mapcar (lambda (x)
 
76
                                           (copy-sequence x))
 
77
                                         (fluid lex-bindings)))
 
78
                           (cons lexically-pure (fluid lexically-pure))
 
79
                           (cons current-stack (fluid current-stack))
 
80
                           (cons max-stack (fluid max-stack))
 
81
                           (cons current-b-stack (fluid current-b-stack))
 
82
                           (cons max-b-stack (fluid max-b-stack)))
 
83
                     (fluid saved-state))))
 
84
 
 
85
  (define (pop-state)
 
86
    (fluid-set saved-state (cdr (fluid saved-state))))
 
87
 
 
88
  ;; reload lex-bindings value, preserving eq-ness of cells
 
89
  (define (reload-lex-bindings saved)
 
90
    (let loop ((rest (fluid lex-bindings)))
 
91
      (if (eq (caar rest) (caar saved))
 
92
          (progn
 
93
            (fluid-set lex-bindings rest)
 
94
            (do ((old rest (cdr old))
 
95
                 (new saved (cdr new)))
 
96
                ((null old))
 
97
              (rplacd (car old) (cdr (car new)))))
 
98
        (loop (cdr rest)))))
 
99
 
 
100
  (define (reload-state)
 
101
    (mapc (lambda (cell)
 
102
            (if (eq (car cell) lex-bindings)
 
103
                (reload-lex-bindings (cdr cell))
 
104
              (fluid-set (car cell) (cdr cell))))
 
105
          (car (fluid saved-state)))))