← Back to branch summary

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

« back to all changes in this revision

Viewing changes to lisp/rep/vm/compiler/rep.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/rep.jl
 
1
#| rep.jl -- inliners for many rep language features
 
2
 
 
3
   $Id: rep.jl,v 1.48 2001/09/03 03:34:32 jsh 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.rep ()
 
27
 
 
28
    (open rep
 
29
          rep.lang.doc
 
30
          rep.vm.bytecodes
 
31
          rep.vm.compiler.modules
 
32
          rep.vm.compiler.utils
 
33
          rep.vm.compiler.basic
 
34
          rep.vm.compiler.inline
 
35
          rep.vm.compiler.lap
 
36
          rep.vm.compiler.bindings)
 
37
 
 
38
  ;; List of side-effect-free functions. They should always return the
 
39
  ;; same value when given the same inputs. Used when constant folding.
 
40
  (define constant-functions
 
41
    '(+ - * / % mod max min 1+ 1- car cdr assoc assq rassoc rassq nth nthcdr
 
42
      last member memq arrayp aref substring concat length elt lognot not
 
43
      logior logxor logand equal = /= > < >= <= ash zerop null atom consp
 
44
      listp numberp integerp stringp vectorp bytecodep functionp macrop
 
45
      special-form-p subrp sequencep string-head-eq string-equal
 
46
      string-lessp string-match string-looking-at quote-regexp
 
47
      complete-string time-later-p alpha-char-p upper-case-p lower-case-p
 
48
      digit-char-p alphanumericp space-char-p char-upcase char-downcase
 
49
      quotient floor ceiling truncate round exp log sin cos tan asin acos
 
50
      atan sqrt expt prin1-to-string read-from-string assoc-regexp
 
51
      string= string< nop identity caar cdar cadr cddr caaar cdaar
 
52
      cadar cddar caadr cdadr caddr cdddr positivep negativep oddp
 
53
      evenp abs lcm % modulo lsh string-upper-case-p string-lower-case-p
 
54
      string-capitalized-p))
 
55
 
 
56
  ;; List of symbols, when the name of the function called by a top-level
 
57
  ;; form is one of these that form is compiled.
 
58
  (define top-level-compiled
 
59
    '(if cond when unless let let* letrec catch unwind-protect condition-case
 
60
      progn prog1 prog2 while and or case define-structure structure))
 
61
 
 
62
  ;; List of symbols, when the car of a top-level form is a member of this
 
63
  ;; list, don't macroexpand the form before compiling.
 
64
  (define top-level-unexpanded
 
65
    '(defun defmacro defvar defconst defsubst %define require
 
66
      declare eval-when-compile define-structure structure))
 
67
 
 
68
 
 
69
;;; pass 1 support
 
70
 
 
71
  (defun pass-1 (forms) (add-progns (pass-1* forms)))
 
72
 
 
73
  (defun pass-1* (forms) (lift-progns (mapcar do-pass-1 forms)))
 
74
 
 
75
  ;; flatten progn forms into their container
 
76
  (defun lift-progns (forms)
 
77
    (let loop ((rest (reverse forms))
 
78
               (out '()))
 
79
      (cond ((null rest) out)
 
80
            ((eq (caar rest) 'progn)
 
81
             (loop (cdr rest) (append (cdar rest) out)))
 
82
            (t (loop (cdr rest) (cons (car rest) out))))))
 
83
 
 
84
  ;; merge `non-top-level' forms into progn blocks. These will then
 
85
  ;; get compiled into single run-byte-code forms
 
86
  (defun add-progns (forms)
 
87
    (let loop ((rest forms))
 
88
      (cond ((null rest) forms)
 
89
            ((memq (caar rest) top-level-unexpanded) (loop (cdr rest)))
 
90
            (t (unless (eq (caar rest) 'progn)
 
91
                 (rplaca rest (list 'progn (car rest))))
 
92
               (if (and (cadr rest)
 
93
                        (not (memq (caadr rest) top-level-unexpanded)))
 
94
                   (progn
 
95
                     (rplaca rest (nconc (car rest) (list (cadr rest))))
 
96
                     (rplacd rest (cddr rest))
 
97
                     (loop rest))
 
98
                 (loop (cdr rest)))))))
 
99
 
 
100
  (defun do-pass-1 (form)
 
101
    (let-fluids ((current-form form))
 
102
      (unless (or (memq (car form) top-level-unexpanded)
 
103
                  (memq (car form) top-level-compiled))
 
104
        (setq form (compiler-macroexpand
 
105
                    form (lambda (in out)
 
106
                           (or (eq in out)
 
107
                               (memq (car out) top-level-unexpanded)
 
108
                               (memq (car out) top-level-compiled))))))
 
109
      (case (car form)
 
110
        ((defun)
 
111
         (remember-function (nth 1 form) (nth 2 form) (nthcdr 3 form)))
 
112
 
 
113
        ((defmacro)
 
114
         (remember-function (nth 1 form) (nth 2 form))
 
115
         (note-macro-def (nth 1 form) (cons 'lambda (nthcdr 2 form))))
 
116
 
 
117
        ((defsubst)
 
118
         (fluid-set inline-env (cons (cons (nth 1 form)
 
119
                                           (cons 'lambda (nthcdr 2 form)))
 
120
                                     (fluid inline-env))))
 
121
 
 
122
        ((defvar)
 
123
         (remember-variable (nth 1 form)))
 
124
 
 
125
        ((defconst)
 
126
         (remember-variable (nth 1 form))
 
127
         (fluid-set const-env (cons (cons (nth 1 form) (nth 2 form))
 
128
                                    (fluid const-env))))
 
129
 
 
130
        ((%define) (remember-lexical-variable (nth 1 form)))
 
131
 
 
132
        ((require)
 
133
         (if (compiler-constant-p (cadr form))
 
134
             (note-require (compiler-constant-value (cadr form)))
 
135
           ;; hmm..
 
136
           (eval form)))
 
137
 
 
138
        ((declare)
 
139
         (note-declaration (cdr form)))
 
140
 
 
141
        ((eval-when-compile)
 
142
         (if (and (eq (car (nth 1 form)) 'require)
 
143
                  (compiler-constant-p (cadr (nth 1 form))))
 
144
             (note-require (compiler-constant-value (cadr (nth 1 form))))
 
145
           (eval (nth 1 form))))
 
146
 
 
147
        ((progn)
 
148
         (setq form (cons 'progn (pass-1* (cdr form)))))
 
149
 
 
150
        ;; put bare forms into progns so they can be merged in pass-1
 
151
        (t (unless (memq (car form) top-level-unexpanded)
 
152
             (setq form (list 'progn form)))))
 
153
 
 
154
      form))
 
155
 
 
156
 
 
157
;;; pass 2 support
 
158
 
 
159
  (defun pass-2 (forms)
 
160
    (let loop ((rest forms)
 
161
               (out '()))
 
162
      (if (null rest)
 
163
          (nreverse out)
 
164
        (loop (cdr rest) (cons (do-pass-2 (car rest)) out)))))
 
165
 
 
166
  (defun do-pass-2 (form)
 
167
    (let-fluids ((current-form form))
 
168
      (case (car form)
 
169
        ((defun defsubst)
 
170
         (let ((tmp (assq (nth 1 form) (fluid macro-env))))
 
171
           (let-fluids ((current-fun (nth 1 form)))
 
172
             ;;(format standard-error "[%s]\n" (fluid current-fun))
 
173
             (when tmp
 
174
               (rplaca tmp nil)
 
175
               (rplacd tmp nil))
 
176
             (list 'defun (nth 1 form)
 
177
                   (compile-lambda (cons 'lambda (nthcdr 2 form))
 
178
                                   (nth 1 form))))))
 
179
 
 
180
        ((defmacro)
 
181
         (let ((code (compile-lambda (cons 'lambda (nthcdr 2 form))
 
182
                                     (nth 1 form)))
 
183
               (tmp (assq (nth 1 form) (fluid macro-env))))
 
184
           (let-fluids ((current-fun (nth 1 form)))
 
185
             (if tmp
 
186
                 (rplacd tmp (make-closure code))
 
187
               (compiler-error
 
188
                "compiled macro `%s' wasn't in environment" (nth 1 form)))
 
189
             (list 'defmacro (nth 1 form) code))))
 
190
 
 
191
        ((defconst)
 
192
         (let ((doc (nth 3 form)))
 
193
           (when (and *compiler-write-docs* (stringp doc))
 
194
             (add-documentation (nth 1 form) (fluid current-module) doc)
 
195
             (setq form (delq doc form)))
 
196
           (unless (memq (nth 1 form) (fluid defvars))
 
197
             (remember-variable (nth 1 form)))
 
198
           (unless (assq (nth 1 form) (fluid const-env))
 
199
             (compiler-warning
 
200
              'bindings "unknown constant `%s'" (nth 1 form))))
 
201
         form)
 
202
 
 
203
        ((defvar)
 
204
         (let ((value (nth 2 form))
 
205
               (doc (nth 3 form)))
 
206
           (when (and (listp value)
 
207
                      (not (compiler-constant-p value)))
 
208
             ;; Compile the definition. A good idea?
 
209
             (rplaca (nthcdr 2 form) (compile-form (nth 2 form))))
 
210
           (when (and *compiler-write-docs* (stringp doc))
 
211
             (add-documentation (nth 1 form) nil doc)
 
212
             (setq form (delq (nth 3 form) form)))
 
213
           (unless (memq (nth 1 form) (fluid defvars))
 
214
             (remember-variable (nth 1 form))))
 
215
         form)
 
216
 
 
217
        ((%define)
 
218
         (let ((sym (nth 1 form))
 
219
               (value (nth 2 form))
 
220
               (doc (nth 3 form)))
 
221
           (unless (memq sym (fluid defines))
 
222
             (remember-lexical-variable (compiler-constant-value sym)))
 
223
           (when (and *compiler-write-docs* (stringp doc))
 
224
             (add-documentation sym (fluid current-module) doc)
 
225
             (setq form (delq doc form)))
 
226
           (when (and (listp value) (not (compiler-constant-p value)))
 
227
             ;; Compile the definition. A good idea?
 
228
             (rplaca (nthcdr 2 form) (compile-form (nth 2 form))))
 
229
           form))
 
230
 
 
231
        ((define-structure)
 
232
         (compile-top-level-define-structure form))
 
233
 
 
234
        ((structure)
 
235
         (compile-top-level-structure form))
 
236
 
 
237
        ((eval-when-compile) nil)
 
238
 
 
239
        (t (if (memq (car form) top-level-compiled)
 
240
               (compile-form form)
 
241
             form)))))
 
242
 
 
243
 
 
244
;;; Source code transformations. These are basically macros that are only
 
245
;;; used at compile-time.
 
246
 
 
247
  ;; tells the constant-folder which functions can be removed
 
248
  (defun foldablep (name)
 
249
    (memq name constant-functions))
 
250
 
 
251
  (defun trans-setq (form)
 
252
    (let
 
253
        (lst)
 
254
      (setq form (cdr form))
 
255
      (while form
 
256
        (unless (consp (cdr form))
 
257
          (compiler-error "odd number of args to setq"))
 
258
        (setq lst (cons `(set ',(car form) ,(nth 1 form)) lst))
 
259
        (setq form (nthcdr 2 form)))
 
260
      (cons 'progn (nreverse lst))))
 
261
  (put 'setq 'rep-compile-transform trans-setq)
 
262
 
 
263
  (defun trans-defvar (form)
 
264
    (let
 
265
        ((name (nth 1 form))
 
266
         (value (nth 2 form))
 
267
         (doc (nth 3 form)))
 
268
      (remember-variable name)
 
269
      (when (and (compiler-constant-p doc)
 
270
                 (stringp (compiler-constant-value doc))
 
271
                 *compiler-write-docs*)
 
272
        (add-documentation name nil (compiler-constant-value doc))
 
273
        (setq doc nil))
 
274
      `(progn
 
275
         ,@(and doc (list `(put ',name 'variable-documentation ,doc)))
 
276
         (make-variable-special ',name)
 
277
         (unless (boundp ',name)
 
278
           (setq ,name ,value)))))
 
279
  (put 'defvar 'rep-compile-transform trans-defvar)
 
280
 
 
281
  (defun trans-require (form)
 
282
    (let
 
283
        ((feature (nth 1 form)))
 
284
      (when (compiler-constant-p feature)
 
285
        (note-require (compiler-constant-value feature)))
 
286
      ;; Must transform to something other than (require FEATURE) to
 
287
      ;; prevent infinite regress
 
288
      `(funcall require ,feature)))
 
289
  (put 'require 'rep-compile-transform trans-require)
 
290
 
 
291
  (defun trans-/= (form)
 
292
    `(not (= ,@(cdr form))))
 
293
  (put '/= 'rep-compile-transform trans-/=)
 
294
 
 
295
 
 
296
;;; Functions which compile non-standard functions (ie special-forms)
 
297
 
 
298
  ;; module compilers from compiler-modules
 
299
  (put 'structure 'rep-compile-fun compile-structure)
 
300
  (put 'define-structure 'rep-compile-fun compile-define-structure)
 
301
  (put 'structure-ref 'rep-compile-fun compile-structure-ref)
 
302
 
 
303
  (defun compile-declare (form)
 
304
    (note-declaration (cdr form))
 
305
    (compile-constant nil))
 
306
  (put 'declare 'rep-compile-fun compile-declare)
 
307
 
 
308
  (defun compile-quote (form)
 
309
    (compile-constant (car (cdr form))))
 
310
  (put 'quote 'rep-compile-fun compile-quote)
 
311
 
 
312
  (defun compile-function (form)
 
313
    (compile-form-1 (cadr form)))
 
314
  (put 'function 'rep-compile-fun compile-function)
 
315
 
 
316
  (defun compile-lambda-form (form)
 
317
    (compile-lambda-constant form))
 
318
  (put 'lambda 'rep-compile-fun compile-lambda-form)
 
319
 
 
320
  (defun compile-while (form)
 
321
    (let
 
322
        ((top-label (make-label))
 
323
         (test-label (make-label)))
 
324
      (emit-insn `(jmp ,test-label))
 
325
      (fix-label top-label)
 
326
      (compile-body (nthcdr 2 form))
 
327
      (emit-insn '(pop))
 
328
      (decrement-stack)
 
329
      (fix-label test-label)
 
330
      (compile-form-1 (nth 1 form))
 
331
      (emit-insn `(jpt ,top-label))))
 
332
  (put 'while 'rep-compile-fun compile-while)
 
333
 
 
334
  (defun compile-%define (form)
 
335
    (compile-constant (nth 1 form))
 
336
    (compile-form-1 (nth 2 form))
 
337
    (emit-insn '(%define))
 
338
    (decrement-stack))
 
339
  (put '%define 'rep-compile-fun compile-%define)
 
340
 
 
341
  ;; Compile mapc specially if we can open code the function call
 
342
  (defun compile-mapc (form)
 
343
    (let
 
344
        ((fun (nth 1 form))
 
345
         (lst (nth 2 form)))
 
346
      (if (constant-function-p fun)
 
347
          ;; We can open code the function
 
348
          (let
 
349
              ((top-label (make-label))
 
350
               (test-label (make-label)))
 
351
            (setq fun (constant-function-value fun))
 
352
            (compile-form-1 lst)
 
353
            (emit-insn `(jmp ,test-label))
 
354
            (fix-label top-label)
 
355
            (emit-insn '(dup))
 
356
            (increment-stack)
 
357
            (emit-insn '(car))
 
358
            (compile-lambda-inline fun nil 1)
 
359
            (emit-insn '(pop))
 
360
            (decrement-stack)
 
361
            (emit-insn '(cdr))
 
362
            (fix-label test-label)
 
363
            ;; I don't have a jump-if-t-but-never-pop instruction, so
 
364
            ;; make one out of "jpt TOP; nil". If I ever get a peep hole
 
365
            ;; optimiser working, the nil should be fodder for it..
 
366
            (emit-insn `(jtp ,top-label))
 
367
            (emit-insn '(push ())))
 
368
        ;; The function must be called, so just use the mapc opcode
 
369
        (compile-form-1 fun)
 
370
        (compile-form-1 lst)
 
371
        (emit-insn '(mapc))
 
372
        (decrement-stack))))
 
373
  (put 'mapc 'rep-compile-fun compile-mapc)
 
374
 
 
375
  (defun compile-progn (form #!optional return-follows)
 
376
    (compile-body (cdr form) return-follows))
 
377
  (put 'progn 'rep-compile-fun compile-progn)
 
378
 
 
379
  (defun compile-prog1 (form)
 
380
    (compile-form-1 (nth 1 form))
 
381
    (compile-body (nthcdr 2 form))
 
382
    (emit-insn '(pop))
 
383
    (decrement-stack))
 
384
  (put 'prog1 'rep-compile-fun compile-prog1)
 
385
 
 
386
  (defun compile-set (form)
 
387
    (let ((sym (nth 1 form))
 
388
          (val (nth 2 form)))
 
389
      (if (compiler-constant-p sym)
 
390
          ;; use setq
 
391
          (progn
 
392
            (setq sym (compiler-constant-value sym))
 
393
            (unless (symbolp sym)
 
394
              (compiler-error "trying to set value of a non-symbol: %s" sym))
 
395
            (compile-form-1 val)
 
396
            (emit-insn '(dup))
 
397
            (increment-stack)
 
398
            (emit-varset sym)
 
399
            (note-binding-modified sym)
 
400
            (decrement-stack))
 
401
        ;; need to preserve left-right evaluation order
 
402
        (compile-form-1 sym)
 
403
        (compile-form-1 val)
 
404
        (emit-insn '(set))
 
405
        (decrement-stack))))
 
406
  (put 'set 'rep-compile-fun compile-set)
 
407
 
 
408
  ;; compile let* specially to coalesce all bindings into a single frame
 
409
  (defun compile-let* (form #!optional return-follows)
 
410
    (let
 
411
        ((lst (car (cdr form))))
 
412
      (call-with-frame
 
413
       (lambda ()
 
414
         (emit-insn '(init-bind))
 
415
         (increment-b-stack)
 
416
         (while (consp lst)
 
417
           (cond ((consp (car lst))
 
418
                  (let ((tmp (car lst)))
 
419
                    (compile-body (cdr tmp))
 
420
                    (test-variable-bind (car tmp))
 
421
                    (note-binding (car tmp))
 
422
                    (emit-binding (car tmp))))
 
423
                 (t (emit-insn '(push ()))
 
424
                    (increment-stack)
 
425
                    (test-variable-bind (car lst))
 
426
                    (note-binding (car lst))
 
427
                    (emit-binding (car lst))))
 
428
           (decrement-stack)
 
429
           (setq lst (cdr lst)))
 
430
         (compile-body (nthcdr 2 form) return-follows)
 
431
         (emit-insn '(unbind))
 
432
         (decrement-b-stack)))))
 
433
  (put 'let* 'rep-compile-fun compile-let*)
 
434
 
 
435
  ;; let can be compiled straight from its macro definition
 
436
 
 
437
  ;; compile letrec specially to handle tail recursion elimination
 
438
  (defun compile-letrec (form #!optional return-follows)
 
439
    (let ((bindings (car (cdr form))))
 
440
      (call-with-frame
 
441
       (lambda ()
 
442
         (push-state)
 
443
         (emit-insn '(init-bind))
 
444
         (increment-b-stack)
 
445
 
 
446
         ;; create the bindings, should really be to void values, but use nil..
 
447
         (mapc (lambda (cell)
 
448
                 (let ((var (or (car cell) cell)))
 
449
                   (test-variable-bind var)
 
450
                   (compile-constant nil)
 
451
                   (note-binding var)
 
452
                   (emit-binding var)
 
453
                   (decrement-stack))) bindings)
 
454
         ;; then set them to their values
 
455
         (mapc (lambda (cell)
 
456
                 (let ((var (or (car cell) cell)))
 
457
                   (compile-body (cdr cell) nil var)
 
458
                   (emit-varset var)
 
459
                   (decrement-stack))) bindings)
 
460
 
 
461
         ;; Test if we can inline it away.
 
462
         ;; Look for forms like (letrec ((foo (lambda (..) body..))) (foo ..))
 
463
         ;; where `foo' only appears in inlinable tail calls in body
 
464
         (when (catch 'no
 
465
                 (unless (= (length bindings) 1)
 
466
                   (throw 'no t))
 
467
                 (let ((var (or (caar bindings) (car bindings)))
 
468
                       (value (cdar bindings)))
 
469
                   (unless (and (binding-tail-call-only-p var)
 
470
                                value (not (cdr value))
 
471
                                (eq (caar value) 'lambda))
 
472
                     (throw 'no t))
 
473
                   (setq value (car value))
 
474
                   (let ((body (nthcdr 2 form)))
 
475
                     (unless (= (length body) 1)
 
476
                       (throw 'no t))
 
477
                     (setq body (car body))
 
478
                     (when (and (eq (car body) (get-language-property
 
479
                                                'compiler-sequencer))
 
480
                                (= (length body) 2))
 
481
                       (setq body (cadr body)))
 
482
                     (unless (eq (car body) var)
 
483
                       (throw 'no t))
 
484
 
 
485
                     ;; okay, let's go
 
486
                     (let-fluids ((silence-compiler t))
 
487
                       (reload-state)
 
488
                       ;; XXX what if this clashes?
 
489
                       (remember-function var (cadr value))
 
490
                       (compile-lambda-inline value (cdr body)
 
491
                                              nil return-follows var)
 
492
                       (forget-function var)
 
493
                       nil))))
 
494
 
 
495
           ;; no, keep on the usual track
 
496
           (compile-body (nthcdr 2 form) return-follows)
 
497
           (emit-insn '(unbind))
 
498
           (decrement-b-stack))
 
499
         (pop-state)))))
 
500
  (put 'letrec 'rep-compile-fun compile-letrec)
 
501
 
 
502
  (defun compile-let-fluids (form)
 
503
    (let ((bindings (cadr form))
 
504
          (body (cddr form)))
 
505
      (call-with-frame
 
506
       (lambda ()
 
507
         (fluid-set lexically-pure nil)
 
508
         ;; compile each fluid, value pair onto the stack
 
509
         (mapc (lambda (cell)
 
510
                 (compile-form-1 (car cell))
 
511
                 (compile-body (cdr cell))) bindings)
 
512
         (emit-insn '(init-bind))
 
513
         (increment-b-stack)
 
514
         (mapc (lambda (unused)
 
515
                 (declare (unused unused))
 
516
                 (emit-insn '(fluid-bind))
 
517
                 (decrement-stack 2)) bindings)
 
518
         (compile-body body)
 
519
         (emit-insn '(unbind))
 
520
         (decrement-b-stack)))))
 
521
  (put 'let-fluids 'rep-compile-fun compile-let-fluids)
 
522
 
 
523
  (defun compile-defun (form)
 
524
    (remember-function (nth 1 form) (nth 2 form))
 
525
    (compile-constant (nth 1 form))
 
526
    (compile-lambda-constant (cons 'lambda (nthcdr 2 form)) (nth 1 form))
 
527
    (emit-insn '(%define))
 
528
    (decrement-stack))
 
529
  (put 'defun 'rep-compile-fun compile-defun)
 
530
 
 
531
  (defun compile-defmacro (form)
 
532
    (remember-function (nth 1 form) (nth 2 form))
 
533
    (compile-constant (nth 1 form))
 
534
    (compile-constant 'macro)
 
535
    (compile-lambda-constant (cons 'lambda (nthcdr 2 form)) (nth 1 form))
 
536
    (emit-insn '(cons))
 
537
    (emit-insn '(%define))
 
538
    (decrement-stack))
 
539
  (put 'defmacro 'rep-compile-fun compile-defmacro)
 
540
 
 
541
  (defun compile-cond (form #!optional return-follows)
 
542
    (let
 
543
        ((end-label (make-label))
 
544
         (need-trailing-nil t))
 
545
      (setq form (cdr form))
 
546
      (while (consp form)
 
547
        (let*
 
548
            ((subl (car form))
 
549
             (condition (car subl))
 
550
             (next-label (make-label)))
 
551
          ;; See if we can squash a constant condition to t or nil
 
552
          (when (compiler-constant-p condition)
 
553
            (setq condition (not (not (compiler-constant-value condition)))))
 
554
          (cond
 
555
           ((eq condition t)
 
556
            ;; condition t -- always taken
 
557
            (if (consp (cdr subl))
 
558
                ;; There's something besides the condition
 
559
                (progn
 
560
                  (compile-body (cdr subl) return-follows)
 
561
                  (decrement-stack))
 
562
              (if (eq condition (car subl))
 
563
                  (emit-insn '(push t))
 
564
                (compile-form-1 (car subl) #:return-follows return-follows)
 
565
                (decrement-stack)))
 
566
            (when (consp (cdr form))
 
567
              ;;(compiler-warning
 
568
              ;; 'misc "unreachable conditions after t in cond statement")
 
569
              ;; Ignore the rest of the statement
 
570
              (setq form nil))
 
571
            (setq need-trailing-nil nil))
 
572
           ((eq condition nil)
 
573
            ;; condition nil -- never taken
 
574
            (when (cdr subl)
 
575
              ;;(compiler-warning
 
576
              ;; 'misc "unreachable forms after nil in cond statement")
 
577
              ))
 
578
           (t
 
579
            ;; non t-or-nil condition
 
580
            (compile-form-1 (car subl)
 
581
                            #:return-follows (and return-follows
 
582
                                                  (null (cdr subl))
 
583
                                                  (null (cdr form))))
 
584
            (decrement-stack)
 
585
            (if (consp (cdr subl))
 
586
                ;; Something besides the condition
 
587
                (if (cdr form)
 
588
                    ;; This isn't the last condition list
 
589
                    (progn
 
590
                      (emit-insn `(jn ,next-label))
 
591
                      (compile-body (cdr subl) return-follows)
 
592
                      (decrement-stack)
 
593
                      (emit-insn `(jmp ,end-label))
 
594
                      (fix-label next-label))
 
595
                  ;; It is the last condition list, use the result
 
596
                  ;; of this condition for the return value when it's
 
597
                  ;; nil
 
598
                  (emit-insn `(jnp ,end-label))
 
599
                  (compile-body (cdr subl) return-follows)
 
600
                  (decrement-stack)
 
601
                  (setq need-trailing-nil nil))
 
602
              ;; No action to take
 
603
              (if (cdr form)
 
604
                  ;; This isn't the last condition list
 
605
                  (emit-insn `(jtp ,end-label))
 
606
                ;; This is the last condition list, since there's no
 
607
                ;; action to take, just fall out the bottom, with the
 
608
                ;; condition as value.
 
609
                (setq need-trailing-nil nil))))))
 
610
        (setq form (cdr form)))
 
611
      (when need-trailing-nil
 
612
        (emit-insn '(push ())))
 
613
      (increment-stack)
 
614
      (fix-label end-label)))
 
615
  (put 'cond 'rep-compile-fun compile-cond)
 
616
 
 
617
  (defun compile-case (form #!optional return-follows)
 
618
    (let
 
619
        ((end-label (make-label))
 
620
         (had-default nil))
 
621
      (setq form (cdr form))
 
622
      (unless form
 
623
        (compiler-error "no key value in case statement"))
 
624
      ;; XXX if key is constant optimise case away..
 
625
      (compile-form-1 (car form))
 
626
      (setq form (cdr form))
 
627
      (while (consp form)
 
628
        (unless (consp form)
 
629
          (compiler-error "badly formed clause in case statement"))
 
630
        (let
 
631
            ((cases (caar form))
 
632
             (forms (cdar form))
 
633
             (next-label (make-label)))
 
634
          (cond ((consp cases)
 
635
                 (emit-insn '(dup))
 
636
                 (increment-stack)
 
637
                 (if (consp (cdr cases))
 
638
                     ;; >1 possible case
 
639
                     (progn
 
640
                       (compile-constant cases)
 
641
                       (emit-insn '(memql)))
 
642
                   ;; only one case, use eql
 
643
                   (compile-constant (car cases))
 
644
                   (emit-insn '(eql)))
 
645
                 (decrement-stack)
 
646
                 (emit-insn `(jn ,next-label))
 
647
                 (decrement-stack))
 
648
                ((eq cases t) (setq had-default t))
 
649
                (t (compiler-error
 
650
                    "badly formed clause in case statement" #:form cases)))
 
651
          (compile-body forms return-follows)
 
652
          (decrement-stack)
 
653
          (emit-insn `(jmp ,end-label))
 
654
          (fix-label next-label)
 
655
          (setq form (cdr form))))
 
656
      (unless had-default
 
657
        (emit-insn '(push ())))
 
658
      (increment-stack)
 
659
      (fix-label end-label)
 
660
      (emit-insn '(swap))
 
661
      (emit-insn '(pop))))
 
662
  (put 'case 'rep-compile-fun compile-case)
 
663
 
 
664
  (defun compile-catch (form)
 
665
    (let
 
666
        ((catch-label (make-label))
 
667
         (start-label (make-label))
 
668
         (end-label (make-label)))
 
669
    (let-fluids ((lexically-pure nil))
 
670
 
 
671
      ;;                jmp start
 
672
      (emit-insn `(jmp ,start-label))
 
673
 
 
674
      ;; catch:
 
675
      ;;                catch TAG
 
676
      ;;                ejmp end
 
677
      (increment-stack)                 ;enter with one arg on stack
 
678
      (fix-label catch-label)
 
679
      (compile-form-1 (nth 1 form))
 
680
      (emit-insn '(catch))
 
681
      (decrement-stack)
 
682
      (emit-insn `(ejmp ,end-label))
 
683
      (decrement-stack)
 
684
 
 
685
      ;; start:
 
686
      ;;                push #catch
 
687
      ;;                binderr
 
688
      ;;                FORMS...
 
689
      ;;                unbind
 
690
      ;; end:
 
691
      (fix-label start-label)
 
692
      (push-label-addr catch-label)
 
693
      (emit-insn '(binderr))
 
694
      (increment-b-stack)
 
695
      (decrement-stack)
 
696
      (compile-body (nthcdr 2 form))
 
697
      (emit-insn '(unbind))
 
698
      (decrement-b-stack)
 
699
      (fix-label end-label))))
 
700
  (put 'catch 'rep-compile-fun compile-catch)
 
701
 
 
702
  (defun compile-unwind-pro (form)
 
703
    (let
 
704
        ((cleanup-label (make-label))
 
705
         (start-label (make-label))
 
706
         (end-label (make-label)))
 
707
    (let-fluids ((lexically-pure nil))
 
708
 
 
709
      ;;                jmp start
 
710
      (emit-insn `(jmp ,start-label))
 
711
 
 
712
      ;; cleanup:
 
713
      ;;                CLEANUP-FORMS
 
714
      ;;                pop
 
715
      ;;                ejmp end
 
716
      ;; [overall, stack +1]
 
717
      (increment-stack 2)
 
718
      (fix-label cleanup-label)
 
719
      (compile-body (nthcdr 2 form))
 
720
      (emit-insn '(pop))
 
721
      (emit-insn `(ejmp ,end-label))
 
722
      (decrement-stack 2)
 
723
 
 
724
      ;; start:
 
725
      ;;                push #cleanup
 
726
      ;;                binderr
 
727
      ;;                FORM
 
728
      ;;                unbind
 
729
      ;;                nil
 
730
      ;;                jmp cleanup
 
731
      ;; [overall, stack +2]
 
732
      (fix-label start-label)
 
733
      (push-label-addr cleanup-label)
 
734
      (emit-insn '(binderr))
 
735
      (increment-b-stack)
 
736
      (decrement-stack)
 
737
      (compile-form-1 (nth 1 form))
 
738
      (emit-insn '(unbind))
 
739
      (decrement-b-stack)
 
740
      (emit-insn '(push ()))
 
741
      (decrement-stack)
 
742
      (emit-insn `(jmp ,cleanup-label))
 
743
 
 
744
      ;; end:
 
745
      (fix-label end-label))))
 
746
  (put 'unwind-protect 'rep-compile-fun compile-unwind-pro)
 
747
 
 
748
  (defun compile-condition-case (form)
 
749
    (let
 
750
        ((cleanup-label (make-label))
 
751
         (start-label (make-label))
 
752
         (end-label (make-label))
 
753
         (handlers (nthcdr 3 form)))
 
754
    (let-fluids ((lexically-pure nil))
 
755
 
 
756
      ;;                jmp start
 
757
      ;; cleanup:
 
758
      (emit-insn `(jmp ,start-label))
 
759
      (fix-label cleanup-label)
 
760
 
 
761
      (increment-stack)         ;reach here with one item on stack
 
762
      (if (consp handlers)
 
763
          (call-with-frame
 
764
           (lambda ()
 
765
             (if (and (nth 1 form) (not (eq (nth 1 form) 'nil)))
 
766
                 (let ((var (nth 1 form)))
 
767
                   (when (spec-bound-p var)
 
768
                     (compiler-error
 
769
                      "condition-case can't bind to special variable `%s'" var))
 
770
                   (test-variable-bind var)
 
771
                   (note-binding var)
 
772
                   ;; XXX errorpro instruction always heap binds..
 
773
                   (tag-binding var 'heap-allocated))
 
774
               ;; something always gets bound
 
775
               (let ((tem (gensym)))
 
776
                 (note-binding tem)
 
777
                 (tag-binding tem 'heap-allocated)
 
778
                 ;; avoid `unused variable' warnings
 
779
                 (note-binding-referenced tem)))
 
780
             ;; Loop over all but the last handler
 
781
             (while (consp (cdr handlers))
 
782
               (if (consp (car handlers))
 
783
                   (let
 
784
                       ((next-label (make-label)))
 
785
                     ;;         push CONDITIONS
 
786
                     ;;         errorpro
 
787
                     ;;         jtp next
 
788
                     ;;         HANDLER
 
789
                     ;;         jmp end
 
790
                     ;; next:
 
791
                     (compile-constant (car (car handlers)))
 
792
                     (emit-insn '(errorpro))
 
793
                     (decrement-stack)
 
794
                     (emit-insn `(jtp ,next-label))
 
795
                     (decrement-stack)
 
796
                     (compile-body (cdr (car handlers)))
 
797
                     (emit-insn `(jmp ,end-label))
 
798
                     (fix-label next-label))
 
799
                 (compiler-error
 
800
                  "badly formed condition-case handler: `%s'"
 
801
                  (car handlers) #:form handlers))
 
802
               (setq handlers (cdr handlers)))
 
803
             ;; The last handler
 
804
             (if (consp (car handlers))
 
805
                 (let
 
806
                     ((pc-label (make-label)))
 
807
                   ;;           push CONDITIONS
 
808
                   ;;           errorpro
 
809
                   ;;           ejmp pc
 
810
                   ;; pc:       HANDLER
 
811
                   ;;           jmp end
 
812
                   (compile-constant (car (car handlers)))
 
813
                   (emit-insn '(errorpro))
 
814
                   (decrement-stack)
 
815
                   (emit-insn `(ejmp ,pc-label))
 
816
                   (fix-label pc-label)
 
817
                   (decrement-stack)
 
818
                   (compile-body (cdr (car handlers)))
 
819
                   (emit-insn `(jmp ,end-label)))
 
820
               (compiler-error
 
821
                "badly formed condition-case handler: `%s'"
 
822
                (car handlers) #:form (car handlers)))))
 
823
        (compiler-error "no handlers in condition-case"))
 
824
      (decrement-stack)
 
825
 
 
826
      ;; start:
 
827
      ;;                push cleanup
 
828
      ;;                binderr
 
829
      ;;                FORM
 
830
      (fix-label start-label)
 
831
      (push-label-addr cleanup-label)
 
832
      (emit-insn '(binderr))
 
833
      (increment-b-stack)
 
834
      (decrement-stack)
 
835
      (compile-form-1 (nth 2 form))
 
836
 
 
837
      ;; end:
 
838
      ;;                unbind                  ;unbind error handler or VAR
 
839
      (fix-label end-label)
 
840
      (emit-insn '(unbind))
 
841
      (decrement-b-stack))))
 
842
  (put 'condition-case 'rep-compile-fun compile-condition-case)
 
843
 
 
844
  (defun compile-list (form)
 
845
    (do ((args (cdr form) (cdr args))
 
846
         (count 0 (1+ count)))
 
847
        ((null args)
 
848
         ;; merge the arguments into a single list
 
849
         (compile-constant '())
 
850
         (do ((i 0 (1+ i)))
 
851
             ((= i count))
 
852
           (emit-insn '(cons))
 
853
           (decrement-stack)))
 
854
      (compile-form-1 (car args))))
 
855
  (put 'list 'rep-compile-fun compile-list)
 
856
 
 
857
  (defun compile-list* (form)
 
858
    (do ((args (cdr form) (cdr args))
 
859
         (count 0 (1+ count)))
 
860
        ((null args)
 
861
         ;; merge the arguments into a single list
 
862
         (do ((i 0 (1+ i)))
 
863
             ((>= i (1- count)))
 
864
           (emit-insn '(cons))
 
865
           (decrement-stack)))
 
866
      (compile-form-1 (car args))))
 
867
  (put 'list* 'rep-compile-fun compile-list*)
 
868
 
 
869
  ;; Funcall normally translates to a single call instruction. However,
 
870
  ;; if the function being called is a constant lambda expression, open
 
871
  ;; code it.
 
872
  (defun compile-funcall (form #!optional return-follows)
 
873
    (let*
 
874
        ((fun (nth 1 form))
 
875
         (args (nthcdr 2 form))
 
876
         (arg-count 0)
 
877
         (open-code (constant-function-p fun)))
 
878
      (unless open-code
 
879
        (compile-form-1 fun))
 
880
      (while args
 
881
        (compile-form-1 (car args))
 
882
        (setq args (cdr args)
 
883
              arg-count (1+ arg-count)))
 
884
      (if open-code
 
885
          (progn
 
886
            (compile-lambda-inline
 
887
             (constant-function-value fun) nil arg-count return-follows)
 
888
            ;; We push one less value than when using 'call
 
889
            (if (zerop arg-count)
 
890
                (increment-stack)
 
891
              (decrement-stack (1- arg-count))))
 
892
        (emit-insn `(call ,arg-count))
 
893
        (note-function-call-made)
 
894
        (decrement-stack arg-count))))
 
895
  (put 'funcall 'rep-compile-fun compile-funcall)
 
896
 
 
897
  (defun compile-apply (form)
 
898
    (compile-form-1 (nth 1 form))
 
899
    (do ((args (nthcdr 2 form) (cdr args))
 
900
         (count 0 (1+ count)))
 
901
        ((null args)
 
902
         ;; merge the arguments into a single list
 
903
         (do ((i 0 (1+ i)))
 
904
             ((>= i (1- count)))
 
905
           (emit-insn '(cons))
 
906
           (decrement-stack)))
 
907
      (compile-form-1 (car args)))
 
908
    (emit-insn '(apply))
 
909
    (decrement-stack))
 
910
  (put 'apply 'rep-compile-fun compile-apply)
 
911
 
 
912
  (defun compile-nth (form)
 
913
    (let
 
914
        ((insn (cdr (assq (nth 1 form) byte-nth-insns))))
 
915
      (if insn
 
916
          (progn
 
917
            (compile-form-1 (nth 2 form))
 
918
            (emit-insn (list insn)))
 
919
        (compile-2-args form))))
 
920
  (put 'nth 'rep-compile-fun compile-nth)
 
921
  (put 'nth 'rep-compile-opcode 'nth)
 
922
 
 
923
  (defun compile-nthcdr (form)
 
924
    (let
 
925
        ((insn (assq (nth 1 form) byte-nthcdr-insns)))
 
926
      (if insn
 
927
          (progn
 
928
            (compile-form-1 (nth 2 form))
 
929
            (when (cdr insn)
 
930
              (emit-insn (list (cdr insn)))))
 
931
        (compile-2-args form))))
 
932
  (put 'nthcdr 'rep-compile-fun compile-nthcdr)
 
933
  (put 'nthcdr 'rep-compile-opcode 'nthcdr)
 
934
 
 
935
  (defun compile-minus (form)
 
936
    (if (/= (length form) 2)
 
937
        (compile-binary-op form)
 
938
      (compile-form-1 (car (cdr form)))
 
939
      (emit-insn '(neg))))
 
940
  (put '- 'rep-compile-fun compile-minus)
 
941
  (put '- 'rep-compile-opcode 'sub)
 
942
 
 
943
  (defun compile-make-closure (form)
 
944
    (when (nthcdr 3 form)
 
945
      (compiler-warning
 
946
       'parameters "more than two parameters to `%s'; rest ignored"
 
947
       (car form)))
 
948
    (compile-form-1 (nth 1 form))
 
949
    (compile-form-1 (nth 2 form))
 
950
    (emit-insn '(make-closure))
 
951
    (note-closure-made)
 
952
    (decrement-stack))
 
953
  (put 'make-closure 'rep-compile-fun compile-make-closure)
 
954
 
 
955
  (defun compile-log (form)
 
956
    (cond ((nthcdr 3 form)
 
957
           (compiler-warning
 
958
            'parameters "more than two parameters to `log'; rest ignored"))
 
959
          ((nthcdr 2 form)
 
960
           ;; dual argument form of log. compiles to
 
961
           (compile-form-1 (nth 1 form))
 
962
           (emit-insn '(log))
 
963
           (compile-form-1 (nth 2 form))
 
964
           (emit-insn '(log))
 
965
           (emit-insn '(div))
 
966
           (decrement-stack))
 
967
          ((nthcdr 1 form)
 
968
           ;; single argument form
 
969
           (compile-form-1 (nth 1 form))
 
970
           (emit-insn '(log)))
 
971
          (t (compiler-warning 'parameters "too few parameters to `log'"))))
 
972
  (put 'log 'rep-compile-fun compile-log)
 
973
 
 
974
  (defun get-form-opcode (form)
 
975
    (cond ((symbolp form) (get form 'rep-compile-opcode))
 
976
          ;; must be a structure-ref
 
977
          ((eq (car form) 'structure-ref)
 
978
           (get (caddr form) 'rep-compile-opcode))
 
979
          (t (compiler-error "don't know opcode for `%s'" form))))
 
980
 
 
981
  ;; Instruction with no arguments
 
982
  (defun compile-0-args (form)
 
983
    (when (cdr form)
 
984
      (compiler-warning
 
985
       'parameters "all parameters to `%s' ignored" (car form)))
 
986
    (emit-insn (list (get-form-opcode (car form))))
 
987
    (increment-stack))
 
988
 
 
989
  ;; Instruction taking 1 arg on the stack
 
990
  (defun compile-1-args (form)
 
991
    (when (nthcdr 2 form)
 
992
      (compiler-warning
 
993
       'parameters "more than one parameter to `%s'; rest ignored" (car form)))
 
994
    (compile-form-1 (nth 1 form))
 
995
    (emit-insn (list (get-form-opcode (car form)))))
 
996
 
 
997
  ;; Instruction taking 2 args on the stack
 
998
  (defun compile-2-args (form)
 
999
    (when (nthcdr 3 form)
 
1000
      (compiler-warning
 
1001
       'parameters "more than two parameters to `%s'; rest ignored"
 
1002
       (car form)))
 
1003
    (compile-form-1 (nth 1 form))
 
1004
    (compile-form-1 (nth 2 form))
 
1005
    (emit-insn (list (get-form-opcode (car form))))
 
1006
    (decrement-stack))
 
1007
 
 
1008
  ;; Instruction taking 3 args on the stack
 
1009
  (defun compile-3-args (form)
 
1010
    (when (nthcdr 4 form)
 
1011
      (compiler-warning
 
1012
       'parameters "More than three parameters to `%s'; rest ignored"
 
1013
       (car form)))
 
1014
    (compile-form-1 (nth 1 form))
 
1015
    (compile-form-1 (nth 2 form))
 
1016
    (compile-form-1 (nth 3 form))
 
1017
    (emit-insn (list (get-form-opcode (car form))))
 
1018
    (decrement-stack 2))
 
1019
 
 
1020
  ;; Compile a form `(OP ARG1 ARG2 ARG3 ...)' into as many two argument
 
1021
  ;; instructions as needed (PUSH ARG1; PUSH ARG2; OP; PUSH ARG3; OP; ...)
 
1022
  (defun compile-binary-op (form)
 
1023
    (let
 
1024
        ((opcode (get-form-opcode (car form))))
 
1025
      (setq form (cdr form))
 
1026
      (unless (>= (length form) 2)
 
1027
        (compiler-error
 
1028
         "too few arguments to binary operator `%s'" (car form)))
 
1029
      (compile-form-1 (car form))
 
1030
      (setq form (cdr form))
 
1031
      (while (consp form)
 
1032
        (compile-form-1 (car form))
 
1033
        (emit-insn (list opcode))
 
1034
        (decrement-stack)
 
1035
        (setq form (cdr form)))))
 
1036
 
 
1037
  ;; Used for >, >=, < and <=
 
1038
  (defun compile-transitive-relation (form)
 
1039
    (cond
 
1040
     ((<= (length form) 2)
 
1041
      (compiler-error "too few args to relation `%s'" (car form)))
 
1042
     ((= (length form) 3)
 
1043
      (let
 
1044
          ((opcode (get-form-opcode (car form))))
 
1045
        ;; Simple case, only two arguments, i.e. `(OP ARG1 ARG2)' into:
 
1046
        ;;  PUSH ARG1; PUSH ARG2; OP;
 
1047
        (compile-form-1 (nth 1 form))
 
1048
        (compile-form-1 (nth 2 form))
 
1049
        (emit-insn (list opcode))
 
1050
        (decrement-stack)))
 
1051
     (t
 
1052
      ;; Tricky case, >2 args,
 
1053
 
 
1054
      ;; Originally I did `(OP ARG1 ARG2 ARG3... ARGN)' as:
 
1055
 
 
1056
      ;;  PUSH ARG1; PUSH ARG2; DUP; SWAP2; OP; JNP Fail;
 
1057
      ;;  PUSH ARG3; DUP; SWAP2; OP; JNP Fail;
 
1058
      ;;  ...
 
1059
      ;;  PUSH ARGN; OP; JMP End;
 
1060
      ;; Fail:
 
1061
      ;;  SWAP; POP;
 
1062
      ;; End:
 
1063
 
 
1064
      ;; But that doesn't always evaluate all arguments..
 
1065
      (compile-funcall (cons 'funcall form)))))
 
1066
 
 
1067
 
 
1068
;;; Opcode properties for the generic instructions, in a progn for compiled
 
1069
;;; speed
 
1070
 
 
1071
  (progn
 
1072
    (put 'cons 'rep-compile-fun compile-2-args)
 
1073
    (put 'cons 'rep-compile-opcode 'cons)
 
1074
    (put 'car 'rep-compile-fun compile-1-args)
 
1075
    (put 'car 'rep-compile-opcode 'car)
 
1076
    (put 'cdr 'rep-compile-fun compile-1-args)
 
1077
    (put 'cdr 'rep-compile-opcode 'cdr)
 
1078
    (put 'rplaca 'rep-compile-fun compile-2-args)
 
1079
    (put 'rplaca 'rep-compile-opcode 'rplaca)
 
1080
    (put 'rplacd 'rep-compile-fun compile-2-args)
 
1081
    (put 'rplacd 'rep-compile-opcode 'rplacd)
 
1082
    (put 'aset 'rep-compile-fun compile-3-args)
 
1083
    (put 'aset 'rep-compile-opcode 'aset)
 
1084
    (put 'aref 'rep-compile-fun compile-2-args)
 
1085
    (put 'aref 'rep-compile-opcode 'aref)
 
1086
    (put 'length 'rep-compile-fun compile-1-args)
 
1087
    (put 'length 'rep-compile-opcode 'length)
 
1088
    (put '+ 'rep-compile-fun compile-binary-op)
 
1089
    (put '+ 'rep-compile-opcode 'add)
 
1090
    (put '* 'rep-compile-fun compile-binary-op)
 
1091
    (put '* 'rep-compile-opcode 'mul)
 
1092
    (put '/ 'rep-compile-fun compile-binary-op)
 
1093
    (put '/ 'rep-compile-opcode 'div)
 
1094
    (put 'remainder 'rep-compile-fun compile-2-args)
 
1095
    (put 'remainder 'rep-compile-opcode 'rem)
 
1096
    (put 'mod 'rep-compile-fun compile-2-args)
 
1097
    (put 'mod 'rep-compile-opcode 'mod)
 
1098
    (put 'lognot 'rep-compile-fun compile-1-args)
 
1099
    (put 'lognot 'rep-compile-opcode 'lnot)
 
1100
    (put 'not 'rep-compile-fun compile-1-args)
 
1101
    (put 'not 'rep-compile-opcode 'not)
 
1102
    (put 'logior 'rep-compile-fun compile-binary-op)
 
1103
    (put 'logior 'rep-compile-opcode 'lor)
 
1104
    (put 'logxor 'rep-compile-fun compile-binary-op)
 
1105
    (put 'logxor 'rep-compile-opcode 'lxor)
 
1106
    (put 'logand 'rep-compile-fun compile-binary-op)
 
1107
    (put 'logand 'rep-compile-opcode 'land)
 
1108
    (put 'ash 'rep-compile-fun compile-2-args)
 
1109
    (put 'ash 'rep-compile-opcode 'ash)
 
1110
    (put 'equal 'rep-compile-fun compile-2-args)
 
1111
    (put 'equal 'rep-compile-opcode 'equal)
 
1112
    (put 'eq 'rep-compile-fun compile-2-args)
 
1113
    (put 'eq 'rep-compile-opcode 'eq)
 
1114
    (put '= 'rep-compile-fun compile-transitive-relation)
 
1115
    (put '= 'rep-compile-opcode 'num-eq)
 
1116
    (put '> 'rep-compile-fun compile-transitive-relation)
 
1117
    (put '> 'rep-compile-opcode 'gt)
 
1118
    (put '< 'rep-compile-fun compile-transitive-relation)
 
1119
    (put '< 'rep-compile-opcode 'lt)
 
1120
    (put '>= 'rep-compile-fun compile-transitive-relation)
 
1121
    (put '>= 'rep-compile-opcode 'ge)
 
1122
    (put '<= 'rep-compile-fun compile-transitive-relation)
 
1123
    (put '<= 'rep-compile-opcode 'le)
 
1124
    (put '1+ 'rep-compile-fun compile-1-args)
 
1125
    (put '1+ 'rep-compile-opcode 'inc)
 
1126
    (put '1- 'rep-compile-fun compile-1-args)
 
1127
    (put '1- 'rep-compile-opcode 'dec)
 
1128
    (put 'zerop 'rep-compile-fun compile-1-args)
 
1129
    (put 'zerop 'rep-compile-opcode 'zerop)
 
1130
    (put 'null 'rep-compile-fun compile-1-args)
 
1131
    (put 'null 'rep-compile-opcode 'not)
 
1132
    (put 'atom 'rep-compile-fun compile-1-args)
 
1133
    (put 'atom 'rep-compile-opcode 'atom)
 
1134
    (put 'consp 'rep-compile-fun compile-1-args)
 
1135
    (put 'consp 'rep-compile-opcode 'consp)
 
1136
    (put 'listp 'rep-compile-fun compile-1-args)
 
1137
    (put 'listp 'rep-compile-opcode 'listp)
 
1138
    (put 'numberp 'rep-compile-fun compile-1-args)
 
1139
    (put 'numberp 'rep-compile-opcode 'numberp)
 
1140
    (put 'stringp 'rep-compile-fun compile-1-args)
 
1141
    (put 'stringp 'rep-compile-opcode 'stringp)
 
1142
    (put 'vectorp 'rep-compile-fun compile-1-args)
 
1143
    (put 'vectorp 'rep-compile-opcode 'vectorp)
 
1144
    (put 'throw 'rep-compile-fun compile-2-args)
 
1145
    (put 'throw 'rep-compile-opcode 'throw)
 
1146
    (put 'boundp 'rep-compile-fun compile-1-args)
 
1147
    (put 'boundp 'rep-compile-opcode 'boundp)
 
1148
    (put 'symbolp 'rep-compile-fun compile-1-args)
 
1149
    (put 'symbolp 'rep-compile-opcode 'symbolp)
 
1150
    (put 'get 'rep-compile-fun compile-2-args)
 
1151
    (put 'get 'rep-compile-opcode 'get)
 
1152
    (put 'put 'rep-compile-fun compile-3-args)
 
1153
    (put 'put 'rep-compile-opcode 'put)
 
1154
    (put 'signal 'rep-compile-fun compile-2-args)
 
1155
    (put 'signal 'rep-compile-opcode 'signal)
 
1156
    (put 'quotient 'rep-compile-fun compile-2-args)
 
1157
    (put 'quotient 'rep-compile-opcode 'quotient)
 
1158
    (put 'reverse 'rep-compile-fun compile-1-args) ; new 12/7/94
 
1159
    (put 'reverse 'rep-compile-opcode 'reverse)
 
1160
    (put 'nreverse 'rep-compile-fun compile-1-args)
 
1161
    (put 'nreverse 'rep-compile-opcode 'nreverse)
 
1162
    (put 'assoc 'rep-compile-fun compile-2-args)
 
1163
    (put 'assoc 'rep-compile-opcode 'assoc)
 
1164
    (put 'assq 'rep-compile-fun compile-2-args)
 
1165
    (put 'assq 'rep-compile-opcode 'assq)
 
1166
    (put 'rassoc 'rep-compile-fun compile-2-args)
 
1167
    (put 'rassoc 'rep-compile-opcode 'rassoc)
 
1168
    (put 'rassq 'rep-compile-fun compile-2-args)
 
1169
    (put 'rassq 'rep-compile-opcode 'rassq)
 
1170
    (put 'last 'rep-compile-fun compile-1-args)
 
1171
    (put 'last 'rep-compile-opcode 'last)
 
1172
    (put 'mapcar 'rep-compile-fun compile-2-args)
 
1173
    (put 'mapcar 'rep-compile-opcode 'mapcar)
 
1174
    (put 'member 'rep-compile-fun compile-2-args)
 
1175
    (put 'member 'rep-compile-opcode 'member)
 
1176
    (put 'memq 'rep-compile-fun compile-2-args)
 
1177
    (put 'memq 'rep-compile-opcode 'memq)
 
1178
    (put 'delete 'rep-compile-fun compile-2-args)
 
1179
    (put 'delete 'rep-compile-opcode 'delete)
 
1180
    (put 'delq 'rep-compile-fun compile-2-args)
 
1181
    (put 'delq 'rep-compile-opcode 'delq)
 
1182
    (put 'delete-if 'rep-compile-fun compile-2-args)
 
1183
    (put 'delete-if 'rep-compile-opcode 'delete-if)
 
1184
    (put 'delete-if-not 'rep-compile-fun compile-2-args)
 
1185
    (put 'delete-if-not 'rep-compile-opcode 'delete-if-not)
 
1186
    (put 'copy-sequence 'rep-compile-fun compile-1-args)
 
1187
    (put 'copy-sequence 'rep-compile-opcode 'copy-sequence)
 
1188
    (put 'sequencep 'rep-compile-fun compile-1-args)
 
1189
    (put 'sequencep 'rep-compile-opcode 'sequencep)
 
1190
    (put 'functionp 'rep-compile-fun compile-1-args)
 
1191
    (put 'functionp 'rep-compile-opcode 'functionp)
 
1192
    (put 'special-form-p 'rep-compile-fun compile-1-args)
 
1193
    (put 'special-form-p 'rep-compile-opcode 'special-form-p)
 
1194
    (put 'subrp 'rep-compile-fun compile-1-args)
 
1195
    (put 'subrp 'rep-compile-opcode 'subrp)
 
1196
    (put 'eql 'rep-compile-fun compile-2-args)
 
1197
    (put 'eql 'rep-compile-opcode 'eql)
 
1198
    (put 'max 'rep-compile-fun compile-binary-op)
 
1199
    (put 'max 'rep-compile-opcode 'max)
 
1200
    (put 'min 'rep-compile-fun compile-binary-op)
 
1201
    (put 'min 'rep-compile-opcode 'min)
 
1202
    (put 'filter 'rep-compile-fun compile-2-args)
 
1203
    (put 'filter 'rep-compile-opcode 'filter)
 
1204
    (put 'macrop 'rep-compile-fun compile-1-args)
 
1205
    (put 'macrop 'rep-compile-opcode 'macrop)
 
1206
    (put 'bytecodep 'rep-compile-fun compile-1-args)
 
1207
    (put 'bytecodep 'rep-compile-opcode 'bytecodep)
 
1208
    (put 'closurep 'rep-compile-fun compile-1-args)
 
1209
    (put 'closurep 'rep-compile-opcode 'closurep)
 
1210
    (put 'thread-forbid 'rep-compile-fun compile-0-args)
 
1211
    (put 'thread-forbid 'rep-compile-opcode 'forbid)
 
1212
    (put 'thread-permit 'rep-compile-fun compile-0-args)
 
1213
    (put 'thread-permit 'rep-compile-opcode 'permit)
 
1214
    (put 'fluid 'rep-compile-fun compile-1-args)
 
1215
    (put 'fluid 'rep-compile-opcode 'fluid-ref)
 
1216
    (put 'fluid-set 'rep-compile-fun compile-2-args)
 
1217
    (put 'fluid-set 'rep-compile-opcode 'fluid-set)
 
1218
 
 
1219
    (put 'caar 'rep-compile-fun compile-1-args)
 
1220
    (put 'caar 'rep-compile-opcode 'caar)
 
1221
    (put 'cadr 'rep-compile-fun compile-1-args)
 
1222
    (put 'cadr 'rep-compile-opcode 'cadr)
 
1223
    (put 'cdar 'rep-compile-fun compile-1-args)
 
1224
    (put 'cdar 'rep-compile-opcode 'cdar)
 
1225
    (put 'cddr 'rep-compile-fun compile-1-args)
 
1226
    (put 'cddr 'rep-compile-opcode 'cddr)
 
1227
    (put 'caddr 'rep-compile-fun compile-1-args)
 
1228
    (put 'caddr 'rep-compile-opcode 'caddr)
 
1229
    (put 'cadddr 'rep-compile-fun compile-1-args)
 
1230
    (put 'cadddr 'rep-compile-opcode 'cadddr)
 
1231
 
 
1232
    (put 'floor 'rep-compile-fun compile-1-args)
 
1233
    (put 'floor 'rep-compile-opcode 'floor)
 
1234
    (put 'ceiling 'rep-compile-fun compile-1-args)
 
1235
    (put 'ceiling 'rep-compile-opcode 'ceiling)
 
1236
    (put 'truncate 'rep-compile-fun compile-1-args)
 
1237
    (put 'truncate 'rep-compile-opcode 'truncate)
 
1238
    (put 'round 'rep-compile-fun compile-1-args)
 
1239
    (put 'round 'rep-compile-opcode 'round)
 
1240
    (put 'exp 'rep-compile-fun compile-1-args)
 
1241
    (put 'exp 'rep-compile-opcode 'exp)
 
1242
    (put 'sin 'rep-compile-fun compile-1-args)
 
1243
    (put 'sin 'rep-compile-opcode 'sin)
 
1244
    (put 'cos 'rep-compile-fun compile-1-args)
 
1245
    (put 'cos 'rep-compile-opcode 'cos)
 
1246
    (put 'tan 'rep-compile-fun compile-1-args)
 
1247
    (put 'tan 'rep-compile-opcode 'tan)
 
1248
    (put 'sqrt 'rep-compile-fun compile-1-args)
 
1249
    (put 'sqrt 'rep-compile-opcode 'sqrt)
 
1250
    (put 'expt 'rep-compile-fun compile-2-args)
 
1251
    (put 'expt 'rep-compile-opcode 'expt)
 
1252
 
 
1253
    ;; some pseudonyms
 
1254
    (put 'string= 'rep-compile-fun compile-2-args)
 
1255
    (put 'string= 'rep-compile-opcode 'equal)
 
1256
    (put 'string< 'rep-compile-fun compile-transitive-relation)
 
1257
    (put 'string< 'rep-compile-opcode 'lt)
 
1258
    (put '% 'rep-compile-fun compile-2-args)
 
1259
    (put '% 'rep-compile-opcode 'rem)
 
1260
    (put 'modulo 'rep-compile-fun compile-2-args)
 
1261
    (put 'modulo 'rep-compile-opcode 'mod)
 
1262
    (put 'lsh 'rep-compile-fun compile-2-args)
 
1263
    (put 'lsh 'rep-compile-opcode 'ash))
 
1264
 
 
1265
  ;; setup properties to tell the compiler where to look for symbols
 
1266
  ;; in the `rep'  package
 
1267
  (unless (get 'rep 'compiler-handler-property)
 
1268
    (put 'rep 'compiler-handler-property 'rep-compile-fun)
 
1269
    (put 'rep 'compiler-transform-property 'rep-compile-transform)
 
1270
    (put 'rep 'compiler-sequencer 'progn)
 
1271
    (put 'rep 'compiler-pass-1 pass-1)
 
1272
    (put 'rep 'compiler-pass-2 pass-2)
 
1273
    (put 'rep 'compiler-foldablep foldablep)))