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
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
|
#| src.jl -- source code program transforms
$Id: src.jl,v 1.8 2000/08/13 19:18:24 john Exp $
Copyright (C) 2000 John Harper <john@dcs.warwick.ac.uk>
This file is part of librep.
librep 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.
librep 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 librep; see the file COPYING. If not, write to
the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
|#
(declare (unsafe-for-call/cc))
(define-structure rep.vm.compiler.src
(export coalesce-constants
mash-constants
source-code-transform)
(open rep
rep.vm.compiler.utils
rep.vm.compiler.modules
rep.vm.compiler.lap
rep.vm.compiler.bindings
rep.vm.bytecodes)
;;; Constant folding
(defun foldablep (name)
(unless (has-local-binding-p name)
(let ((fun (get-procedure-handler name 'compiler-foldablep)))
(and fun (fun name)))))
(defun quote-constant (value)
(if (or (symbolp value) (consp value))
(list 'quote value)
value))
;; This assumes that FORM is a list, and its car is one of the functions
;; in the comp-constant-functions list
(defun fold-constants (form)
(catch 'exit
(let
((args (mapcar (lambda (arg)
(when (consp arg)
(setq arg (compiler-macroexpand arg)))
(when (and (consp arg) (foldablep (car arg)))
(setq arg (fold-constants arg)))
(if (compiler-constant-p arg)
(compiler-constant-value arg)
;; Not a constant, abort, abort
(throw 'exit form)))
(cdr form))))
;; Now we have ARGS, the constant [folded] arguments from FORM
(quote-constant (apply (compiler-symbol-value (car form)) args)))))
(defun coalesce-constants (folder forms)
(when forms
(let loop ((result '())
(first (car forms))
(rest (cdr forms)))
(cond ((null rest) (nreverse (cons first result)))
((and (compiler-constant-p first)
rest (compiler-constant-p (car rest)))
(loop result
(quote-constant
(folder (compiler-constant-value first)
(compiler-constant-value (car rest))))
(cdr rest)))
(t (loop (cons first result) (car rest) (cdr rest)))))))
(defun mash-constants (folder forms)
(let ((consts (filter compiler-constant-p forms))
(non-consts (filter (lambda (x)
(not (compiler-constant-p x))) forms)))
(if consts
(cons (quote-constant
(apply folder (mapcar compiler-constant-value consts)))
non-consts)
non-consts)))
;;; Entry point
(defun source-code-transform (form)
(let (tem)
;; first try constant folding
(when (and (consp form) (foldablep (car form)))
(setq form (fold-constants form)))
;; then look for a specific tranformer
(when (and (symbolp (car form))
(setq tem (get-procedure-handler
(car form) 'compiler-transform-property)))
(setq form (tem form)))
form)))
|
