1
#| src.jl -- source code program transforms
3
$Id: src.jl,v 1.8 2000/08/13 19:18:24 john Exp $
5
Copyright (C) 2000 John Harper <john@dcs.warwick.ac.uk>
7
This file is part of librep.
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)
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.
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.
24
(declare (unsafe-for-call/cc))
26
(define-structure rep.vm.compiler.src
28
(export coalesce-constants
30
source-code-transform)
34
rep.vm.compiler.modules
36
rep.vm.compiler.bindings
41
(defun foldablep (name)
42
(unless (has-local-binding-p name)
43
(let ((fun (get-procedure-handler name 'compiler-foldablep)))
44
(and fun (fun name)))))
46
(defun quote-constant (value)
47
(if (or (symbolp value) (consp value))
51
;; This assumes that FORM is a list, and its car is one of the functions
52
;; in the comp-constant-functions list
53
(defun fold-constants (form)
56
((args (mapcar (lambda (arg)
58
(setq arg (compiler-macroexpand arg)))
59
(when (and (consp arg) (foldablep (car arg)))
60
(setq arg (fold-constants arg)))
61
(if (compiler-constant-p arg)
62
(compiler-constant-value arg)
63
;; Not a constant, abort, abort
66
;; Now we have ARGS, the constant [folded] arguments from FORM
67
(quote-constant (apply (compiler-symbol-value (car form)) args)))))
69
(defun coalesce-constants (folder forms)
71
(let loop ((result '())
74
(cond ((null rest) (nreverse (cons first result)))
75
((and (compiler-constant-p first)
76
rest (compiler-constant-p (car rest)))
79
(folder (compiler-constant-value first)
80
(compiler-constant-value (car rest))))
82
(t (loop (cons first result) (car rest) (cdr rest)))))))
84
(defun mash-constants (folder forms)
85
(let ((consts (filter compiler-constant-p forms))
86
(non-consts (filter (lambda (x)
87
(not (compiler-constant-p x))) forms)))
90
(apply folder (mapcar compiler-constant-value consts)))
96
(defun source-code-transform (form)
98
;; first try constant folding
99
(when (and (consp form) (foldablep (car form)))
100
(setq form (fold-constants form)))
102
;; then look for a specific tranformer
103
(when (and (symbolp (car form))
104
(setq tem (get-procedure-handler
105
(car form) 'compiler-transform-property)))
106
(setq form (tem form)))
added
removed
lisp/rep/vm/compiler/src.jl
