compiler.stk 49.6 KB
Newer Older
Erick Gallesio's avatar
.  
Erick Gallesio committed
1
;;;;
eg's avatar
eg committed
2
;;;; c o m p i l e r . s t k			-- STklos Compiler
Erick's avatar
Erick committed
3
;;;;
4
;;;; Copyright  2000-2011 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
Erick's avatar
Erick committed
5 6
;;;;
;;;;
eg's avatar
eg committed
7 8 9 10
;;;; This program 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 of the License, or
;;;; (at your option) any later version.
Erick's avatar
Erick committed
11
;;;;
eg's avatar
eg committed
12 13 14 15
;;;; This program 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.
Erick's avatar
Erick committed
16
;;;;
eg's avatar
eg committed
17 18
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
Erick's avatar
Erick committed
19
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
eg's avatar
eg committed
20
;;;; USA.
Erick's avatar
Erick committed
21
;;;;
eg's avatar
eg committed
22 23
;;;;           Author: Erick Gallesio [eg@unice.fr]
;;;;    Creation date: 26-Feb-2000 10:47 (eg)
24
;;;; Last file update: 23-Jun-2011 20:21 (eg)
eg's avatar
eg committed
25 26
;;;;

27
(define-module STKLOS-COMPILER
28
  (import SCHEME)
29 30 31
  (export eval
	  disassemble
	  compiler:time-display
32 33
	  compiler:gen-line-number
	  compiler:warn-use-undefined
34
	  compiler:warn-use-undefined-postpone
Erick's avatar
.  
Erick committed
35
	  compiler:show-assembly-code
36
	  compiler:inline-common-functions))
Erick's avatar
Erick committed
37

38
(select-module STKLOS-COMPILER)
eg's avatar
eg committed
39

40 41 42 43 44 45
(define *compiler-port* #f)

(define *inline-table* `((+ 		 . ,+)
			 (- 		 . ,-)
			 (* 		 . ,*)
			 (/		 . ,/)
Erick Gallesio's avatar
Erick Gallesio committed
46 47 48
			 (fx+		 . ,fx+)
			 (fx-		 . ,fx-)
			 (fx*		 . ,fx*)
Erick's avatar
Erick committed
49
			 (fxdiv		 . ,fxdiv)
50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71
			 (=		 . ,=)
			 (<		 . ,<)
			 (<=		 . ,<=)
			 (>		 . ,>)
			 (>=		 . ,>=)
			 (cons	 	 . ,cons)
			 (car	 	 . ,car)
			 (cdr	 	 . ,cdr)
			 (null?	 	 . ,null?)
			 (list	 	 . ,list)
			 (not 	 	 . ,not)
			 (vector-ref	 . ,vector-ref)
			 (vector-set!	 . ,vector-set!)
			 (string-ref	 . ,string-ref)
			 (string-set! 	 . ,string-set!)
			 (eq?	 	 . ,eq?)
			 (eqv?	 	 . ,eqv?)
			 (equal?	 . ,equal?)
			 (void	 	 . ,void)))

(define *inline-symbols* (map car *inline-table*))

Erick's avatar
Erick committed
72
(define *always-inlined*   	'(%set-current-module %%set-current-module
eg's avatar
eg committed
73 74 75 76 77 78 79 80 81 82 83
				  %%execute %%execute-handler))

(define *code-instr*		#f)
(define *code-constants*	'())
(define *code-labels*		0)

(include "peephole.stk")
(include "assembler.stk")
(include "computils.stk")


84 85 86 87

;; ----------------------------------------------------------------------
;; Debbugging support
;; ----------------------------------------------------------------------
Erick Gallesio's avatar
Erick Gallesio committed
88
;;= (export %compiler-debug)
Erick's avatar
Erick committed
89
;;=
Erick Gallesio's avatar
Erick Gallesio committed
90
;;= (define %compiler-debug (make-parameter #f))
Erick's avatar
Erick committed
91
;;=
Erick Gallesio's avatar
Erick Gallesio committed
92 93
;;= (define (dprintf . args)
;;=   (when  (%compiler-debug) (apply eprintf args)))
Erick's avatar
Erick committed
94
;;=
95

eg's avatar
eg committed
96 97 98
;; ----------------------------------------------------------------------
;; 	Compiler parameters ...
;; ----------------------------------------------------------------------
99 100 101
(define compiler:time-display			(make-parameter #t))
(define compiler:gen-line-number		(make-parameter #f))
(define compiler:warn-use-undefined  		(make-parameter #f))
Erick Gallesio's avatar
Erick Gallesio committed
102
(define compiler:warn-use-undefined-postpone	(make-parameter #t))
Erick's avatar
.  
Erick committed
103
(define compiler:show-assembly-code		(make-parameter #f))
104

105 106 107 108 109 110
(define compiler:inline-common-functions
  (let ((inlined *inline-symbols*))
    (make-parameter #t
		    (lambda (v)
		      (set! *inline-symbols* (if v inlined '()))
		      (not (null? *inline-symbols*))))))
eg's avatar
eg committed
111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137

(define (new-label)
  (let ((lab *code-labels*))
    (set! *code-labels* (+ *code-labels* 1))
    lab))

(define (emit . args)
  (set! *code-instr* (cons args *code-instr*)))

(define (emit-label lab)
  (set! *code-instr* (cons lab *code-instr*)))


; ======================================================================
;
; 				CONSTANTS
;
; ======================================================================

(define (fetch-constant c)
  (let ((x (member c *code-constants*)))
    (unless x
      ;; This constant was not in the table; add it.
      (set! x (list c))
      (set! *code-constants* (append! *code-constants* x)))
    (- (length *code-constants*) (length x))))

138
(define small-integer-constant?
eg's avatar
eg committed
139 140
  (let ((min-int (- (expt 2 15)))
	(max-int (- (expt 2 15) 1)))
141 142 143 144
    (lambda (v)
      (and (integer? v)
	   (exact? v)
	   (<= min-int v max-int)))))
Erick's avatar
Erick committed
145

146
(define (compile-constant v env tail?)
Erick's avatar
Erick committed
147
  (cond
148 149 150 151 152 153 154 155 156
    ((eq? v #t)    		       (emit 'IM-TRUE))
    ((eq? v #f)    		       (emit 'IM-FALSE))
    ((eq? v '())   		       (emit 'IM-NIL))
    ((eq? v -1)    		       (emit 'IM-MINUS1))
    ((eq? v 0)     		       (emit 'IM-ZERO))
    ((eq? v 1)     		       (emit 'IM-ONE))
    ((eq? v (void))		       (emit 'IM-VOID))
    ((small-integer-constant? v)       (emit 'SMALL-INT v))
    (else 			       (emit 'CONSTANT (fetch-constant v)))))
eg's avatar
eg committed
157 158 159 160 161 162 163


#|
<doc syntax quote
 * (quote <datum>)
 * '<datum>
 *
Erick's avatar
Erick committed
164 165
 * The quoting mechanism is identical to R5RS, except that keywords
 * constants  evaluate "to themselves" as numerical constants, string
eg's avatar
eg committed
166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193
 * constants, character constants, and boolean constants
 * @lisp
 * '"abc"     =>  "abc"
 * "abc"      =>  "abc"
 * '145932    =>  145932
 * 145932     =>  145932
 * '#t        =>  #t
 * #t         =>  #t
 * :foo       =>  :foo
 * ':foo      =>  :foo
 * @end lisp
 * ,(bold "Note:") R5RS requires to quote constant lists and
 * constant vectors. This is not necessary with STklos.
doc>
|#
(define (compile-quote expr env tail?)
  (if (= (length expr) 2)
      (compile-constant (cadr expr) env tail?)
      (compiler-error 'quote expr "bad usage in ~S" expr)))

; ======================================================================
;
;				DEFINE
;
; ======================================================================
(define *forward-globals* '())

(define (known-var? symbol)
Erick Gallesio's avatar
Erick Gallesio committed
194 195
  (or (symbol-bound? symbol)
      (memq symbol (compiler-known-globals))))
eg's avatar
eg committed
196 197 198 199 200 201


(define (compiler-warn-undef symbol epair)
  (compiler-warning (void) epair "reference to undefined symbol ~S" symbol))

(define (verify-global symbol epair)
202 203 204 205 206 207
  (unless (known-var? symbol)
    (cond
      ((compiler:warn-use-undefined-postpone)
       (set! *forward-globals* (cons (cons symbol epair) *forward-globals*)))
      ((compiler:warn-use-undefined)
       (compiler-warn-undef symbol epair)
Erick Gallesio's avatar
Erick Gallesio committed
208
       (register-new-global! symbol))))) 	; to avoid multiple warnings
209

eg's avatar
eg committed
210 211 212 213 214 215 216

(define (compiler-show-undefined-symbols)
  (for-each (lambda (x)
	      (let ((symbol (car x))
		    (where  (cdr x)))
		(unless (known-var? symbol)
		  (compiler-warn-undef symbol where)
Erick Gallesio's avatar
Erick Gallesio committed
217
		  (register-new-global! symbol)))) ;; to avoid multiple warnings
eg's avatar
eg committed
218 219 220
	    *forward-globals*)
  (set! *forward-globals* '()))

221 222


eg's avatar
eg committed
223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241
(define (define->lambda l)
  (if (> (length l) 2)
      (let ((bind (cadr l))
	    (body (cddr l)))
	(if (pair? bind)
	    `(define ,(car bind) (lambda ,(cdr bind) ,@body))
	    l))
      (begin
	(compiler-error 'define l "ill formed definition ~S" l)
	l)))

(define (compile-define args env tail?)
  (let* ((l   (define->lambda args))
	 (who (cadr l)))
    (if (not (= (length l) 3))
	(compiler-error 'define args "bad definition")
	(if (null? env)
	    (if (symbol? who)
		(begin
Erick Gallesio's avatar
Erick Gallesio committed
242
		  (register-new-global! who)
eg's avatar
eg committed
243 244 245
		  (compile (caddr l) '() args #f)
		  (emit 'DEFINE-SYMBOL (fetch-constant who)))
		(compiler-error 'define args "bad variable name ~S" who))
246
	    (compiler-error 'define args "internal define forbidden here ~S" args)))))
eg's avatar
eg committed
247 248 249 250 251 252 253 254 255 256 257 258 259 260 261


;;;;
;;;; REFERENCES & ASSIGNMENT
;;;;
(define (symbol-in-env? symb env)
  (let Loop ((l env))
    (cond
      ((null? l) 		#f)
      ((memq symb (car l))	#t)
      (else			(Loop (cdr l))))))


(define (compile-access name env epair ref)

Erick's avatar
Erick committed
262
  (define (make-word v1 v2)		  ;; FIXME: Add control
eg's avatar
eg committed
263 264 265 266 267 268 269
    (+ (* v1 256) v2))


  (define (em i1 i2 . args)
    (apply emit (if ref i1 i2) args))

  (let loop ((lev 0) (env env))
Erick's avatar
Erick committed
270
    (if (null? env)
eg's avatar
eg committed
271 272 273 274
	;; name is a global variable
	(begin
	  (verify-global name epair)
	  (em 'GLOBAL-REF 'GLOBAL-SET (fetch-constant name)))
Erick's avatar
Erick committed
275
	;; name is a local variable
eg's avatar
eg committed
276
	(let loop2 ((idx 0) (l (car env)))
Erick's avatar
Erick committed
277 278
	  (cond
	    ((null? l)
eg's avatar
eg committed
279
	     (loop (+ lev 1) (cdr env)))
Erick's avatar
Erick committed
280
	    ((eq? (car l) name)
eg's avatar
eg committed
281 282 283 284 285 286 287 288 289 290
	     (if (zero? lev)
		 ;; variable in  innermost block
		 (case idx
		   ((0)  (em 'LOCAL-REF0 'LOCAL-SET0))
		   ((1)  (em 'LOCAL-REF1 'LOCAL-SET1))
		   ((2)  (em 'LOCAL-REF2 'LOCAL-SET2))
		   ((3)  (em 'LOCAL-REF3 'LOCAL-SET3))
		   ((4)  (em 'LOCAL-REF4 'LOCAL-SET4))
		   (else (em 'LOCAL-REF  'LOCAL-SET  idx)))
		 ;; local variable in a "between" block
291 292 293 294 295
		 (let ((arg (make-word lev idx)))
		   (if (small-integer-constant? arg)
		     (em 'DEEP-LOCAL-REF  'DEEP-LOCAL-SET (make-word lev idx))
		     (em 'DEEP-LOC-REF-FAR 'DEEP-LOC-SET-FAR ;; Use a FAR variants
			 (fetch-constant (cons lev idx)))))))
eg's avatar
eg committed
296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311
	    (else   (loop2 (+ idx 1) (cdr l))))))))


(define (compile-reference name env epair tail?)
  (compile-access name env epair #t))

(define (compile-set! args env tail?)
  (let ((len (length (cdr args))))
    (if (= len 2)
	(let ((var (cadr args))
	      (val (caddr args)))
	  (if (list? var)
	      ;; This is a extended set! usage as in "(set! (f x y z) value)"
	      (compile `((setter ,(car var)) ,@(cdr var) ,val) env args tail?)
	      ;; R5RS usage
	      (if (symbol? var)
Erick's avatar
Erick committed
312
		  (begin
eg's avatar
eg committed
313 314 315
		    (compile val env args #f)
		    (compile-access var env args #f))
		  (compiler-error 'set! args "~S is a bad symbol" var))))
Erick Gallesio's avatar
Erick Gallesio committed
316
	(compiler-error 'set! (cdr args) "bad assignment syntax in ~S" args))))
eg's avatar
eg committed
317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340

;;;;
;;;; IF
;;;;
(define (compile-if args env tail?)
  (let ((len (length (cdr args)))
	(l1  (new-label))
	(l2  (new-label)))
    (if (<= 2 len 3)
	(begin
	  (compile (cadr args) env args #f)
	  (emit 'JUMP-FALSE l1)
	  (compile (caddr args) env args tail?)
	  (emit 'GOTO l2)
	  (emit-label l1)
	  (if (= len 3)
	      (compile (cadddr args) env args tail?)
	      (emit 'IM-VOID))
	  (emit-label l2))
	(compiler-error 'if args "bad syntax in ~S" args))))

;;
;; DEFINE-MACRO
;;
341
(define (compile-define-macro e env tail?)
Erick's avatar
Erick committed
342
  ;; Called for global macros.
343 344 345
  (if (null? env)
      (let ((l (define->lambda e)))
	(when (= (length l) 3)
Erick Gallesio's avatar
.  
Erick Gallesio committed
346
	  (let* ((l	   (extended-lambda->lambda l))
347 348 349 350
		 (name     (cadr l))
		 (proc     (caddr l))
		 (expander `(lambda (form e) (apply ,proc (cdr form)))))
	    ;; Install expander for further compilation
Erick Gallesio's avatar
.  
Erick Gallesio committed
351
	    (install-expander! name (eval expander) proc)
Erick Gallesio's avatar
Erick Gallesio committed
352 353 354 355
	    ;; Compile code for installing expander (for byte-code files)
	    ;; YES! we need both (install + compile)
	    (compile expander '() e #f)
	    (emit 'MAKE-EXPANDER (fetch-constant name)))))
356 357 358 359 360 361
      (compiler-error 'define-macro e "internal define-macro forbidden here ~S" e)))


(define (compile-internal-define-macro e env tail?)
  ;; This one is called when we find a define-macro while rewriting a body
  ;; (for internal defines -> letrec)
eg's avatar
eg committed
362 363
  (let ((l (define->lambda e)))
    (when (= (length l) 3)
Erick Gallesio's avatar
.  
Erick Gallesio committed
364
      (let* ((l        (extended-lambda->lambda l))
eg's avatar
eg committed
365 366 367
	     (name     (cadr l))
	     (proc     (caddr l))
	     (expander `(lambda (form e) (apply ,proc (cdr form)))))
368 369 370 371
	;; Push expander for further compilation (shadowing global macro)
	(push-expander! name (eval expander))
	;; return the name of the defined macro
	name))))
eg's avatar
eg committed
372 373 374 375

;;;;
;;;; WHEN/UNLESS
;;;;
Erick Gallesio's avatar
Erick Gallesio committed
376 377
(define-macro (when . args)
  (let ((len (length args)))
eg's avatar
eg committed
378
    (if (> len 1)
Erick Gallesio's avatar
Erick Gallesio committed
379 380
	`(if ,(car args) (begin ,@(cdr args)))
	(compiler-error 'when args "bad syntax in ~S" `(when ,@args)))))
eg's avatar
eg committed
381

Erick Gallesio's avatar
Erick Gallesio committed
382 383
(define-macro (unless . args)
  (let ((len (length args)))
eg's avatar
eg committed
384
    (if (> len 1)
Erick Gallesio's avatar
Erick Gallesio committed
385 386 387 388 389 390 391 392 393
	`(if (not ,(car args)) (begin ,@(cdr args)))
	(compiler-error 'unless args "bad syntax in ~S" `(unless ,@args)))))


;;;;
;;;; WHEN/UNLESS
;;;;
(define-macro (set! . args)
  `(%%set! ,@args))
eg's avatar
eg committed
394 395 396 397 398 399 400 401 402 403 404 405 406


#|

				A N D

<doc syntax and
 * (and <test1> ...)
 *
 * The |<test>| expressions are evaluated from left to right, and the
 * value of the first expression that evaluates to a false value is
 * returned.  Any remaining expressions are not evaluated.  If all the
 * expressions evaluate to true values, the value of the last expression
407
 * is returned.  If there are no expressions then |%t| is returned.
Erick's avatar
Erick committed
408
 *
eg's avatar
eg committed
409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424
 * @lisp
 *   (and (= 2 2) (> 2 1))           =>  #t
 *   (and (= 2 2) (< 2 1))           =>  #f
 *   (and 1 2 'c '(f g))             =>  (f g)
 *   (and)                           =>  #t
 * @end lisp
doc>
|#
(define (compile-and args env tail?)
  (if (null? (cdr args))
      ;; Case (and) ==> #t
      (emit 'IM-TRUE)
      ;; General case
      ;; code for (and x1 x2 .. xn) is
      ;;      x1; jump-false l1; x2; jump-false l1; ... goto l2; l1: im-false; L2:
      (let ((lab1 (new-label))
Erick's avatar
Erick committed
425
	    (lab2 (new-label)))
eg's avatar
eg committed
426 427 428 429 430 431 432 433 434 435 436 437
	(let Loop ((l (cdr args)))
	  (cond ((null? l) 	     #f)
		((null? (cdr l))     (compile (car l) env args tail?))
		(else  	     	     (compile (car l) env args #f)
				     (emit 'JUMP-FALSE lab1)
				     (Loop (cdr l)))))
	(emit 'GOTO lab2)
	(emit-label lab1)
	(emit 'IM-FALSE)
	(emit-label lab2))))

#|
Erick's avatar
Erick committed
438

eg's avatar
eg committed
439 440 441 442 443 444 445 446 447
				O R
 *
<doc syntax or
 * (or <test1> ...)
 *
 * The |<test>| expressions are evaluated from left to right, and the
 * value of the first expression that evaluates to a true value is
 * returned.  Any remaining expressions are not evaluated.  If all
 * expressions evaluate to false values, the value of the last expression
448
 * is returned.  If there are no expressions then |%f| is returned.
Erick's avatar
Erick committed
449
 *
eg's avatar
eg committed
450 451 452 453
 * @lisp
 *   (or (= 2 2) (> 2 1))            =>  #t
 *   (or (= 2 2) (< 2 1))            =>  #t
 *   (or #f #f #f)                   =>  #f
Erick's avatar
Erick committed
454
 *   (or (memq 'b '(a b c))
eg's avatar
eg committed
455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470
 *       (/ 3 0))                    =>  (b c)
 * @end lisp
doc>
|#
(define (compile-or args env tail?)
  ;; General case
  ;; code for (or x1 x2 .. xn) is
  ;;      x1; jump-true l1; x2; jump-true l1; ... ; im-false; L1:
  (let ((lab (new-label)))
    (let Loop ((l (cdr args)))
      (unless (null? l)
	(compile (car l) env args (and tail? (null? (cdr l))))
	(emit 'JUMP-TRUE lab)
	(Loop (cdr l))))
    (emit 'IM-FALSE)
    (emit-label lab)))
Erick's avatar
Erick committed
471

eg's avatar
eg committed
472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497

;;;;
;;;; BEGIN
;;;;
(define (compile-begin args env tail?)
  (let ((len (length (cdr args))))
    (case len
      ((0) ;; Body without form
           (emit 'IM-VOID))
      ((1) ;; A begin with only one sexpr in it
       	   (compile (cadr args) env args tail?))
      (else ;; General case
           (let Loop ((body (cdr args)))
	     (if (null? (cdr body))
		 ;; last expression of the begin
		 (compile (car body) env args tail?)
		 ;; expression in the middle
		 (begin
		   (compile (car body) env args #f)
		   (Loop (cdr body)))))))))

;;;;
;;;; LAMBDA
;;;;
(define (compute-arity l)
  (let loop ((l l) (n 0))
Erick's avatar
Erick committed
498
    (cond
eg's avatar
eg committed
499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518
       ((null? l) n)
       ((pair? l) (loop (cdr l) (+ n 1)))
       (else      (- (- n) 1)))))

(define (extend-env env formals)
  (letrec ((aux (lambda (l res)
		  (cond
		     ((null? l) res)
		     ((pair? l) (aux (cdr l) (cons (car l) res)))
		     (else      (cons l res))))))
    (cons (aux formals '()) env)))


(define (extend-current-env env symbol)
  ;; Add just symbol to the current environment (used by let*)
  (cons (append (car env) (list symbol))
	(cdr env)))

;;  (define (valid-lambda? expr)
;;    (define (param-ok? l seen)
Erick's avatar
Erick committed
519
;;      (cond
eg's avatar
eg committed
520 521 522 523 524 525 526 527
;;       ((null? l)   #t)
;;       ((symbol? l) (if (memq l seen)
;;  		      (compile-error "duplicate parameter ~S" l)
;;  		      #t))
;;       ((pair? l)   (and (symbol? (car l))
;;  		       (param-ok? (car l) seen)
;;  		       (param-ok? (cdr l) (cons (car l) seen))))
;;       (else	      (compile-error "bad procedure parameter ~S" l))))
Erick's avatar
Erick committed
528
;;
eg's avatar
eg committed
529
;;    ;; code of valid-lambda? starts here
Erick's avatar
Erick committed
530
;;
eg's avatar
eg committed
531 532
;;    (and (> (length expr) 2)
;;         (param-ok? (cadr expr) '())))
Erick's avatar
Erick committed
533
;;
eg's avatar
eg committed
534

535 536 537
(define (compile-body body env epair tail?)

  (define internal-macros '())
Erick's avatar
Erick committed
538

539
  (define (rewrite-body body)
540
    (let Loop ((l body) (defs '()))
541 542 543 544 545
      (let ((cur (cond
		   ((null? l)
		      (error "body is empty"))
		   ((and (pair? l) (pair? (car l)) (expander? (caar l)))
		      (%macro-expand* (car l)))
Erick's avatar
Erick committed
546
		   (else
547
		      (car l)))))
548 549 550 551
	(cond
	  ((and (pair? cur) (eq? (car cur) 'begin))
	    ;; Delete useless begin
	    (Loop (append (cdr cur) (cdr l))
552
		  defs))
553 554 555 556 557 558 559 560
	((and (pair? cur) (eq? (car cur) 'define))
	   ;; This is an internal define
	   (Loop (cdr l) (cons (cdr (define->lambda cur)) defs)))
	((and (pair? cur) (eq? (car cur) 'define-macro))
	   ;; This is an internal define-macro. Add expander + skip expression
	   (let ((name (compile-internal-define-macro cur env #f)))
	     (set! internal-macros (cons name internal-macros))
	     (Loop (cdr l) defs)))
561
	(else
562
	   ;; We have parsed all the (starting) definitions
563 564 565 566 567 568 569
	   (if (null? defs)
	       `(begin ,@l)
	       (let ((defs (reverse! defs)))
		 ;; Generate "similar" to a letrec*
		 `(let ,(map (lambda (x) (list (car x) #f)) defs)
		    ,@(map (lambda (x) `(set! ,@x)) defs)
		    ,@l))))))))
570 571 572 573 574 575

  ;; rewrite the body to transform internal define to letrec
  (compile (rewrite-body body) env epair tail?)

  ;; delete all the internal macros from the list of expanders
  (for-each delete-expander! internal-macros))
eg's avatar
eg committed
576

577

eg's avatar
eg committed
578
(define (compile-user-lambda formals body arity env)	; i.e R5RS ones
579 580 581 582 583 584 585
  (let* ((env  (extend-env env formals))
	 (lab  (new-label))
	 (doc  (if (and (> (length body) 1) (string? (car body)))
		   (car body)
		   #f))
	 (body (if doc (cdr body) body)))

eg's avatar
eg committed
586
    (emit 'CREATE-CLOSURE lab arity)
587
    (compile-body body env body #t)
eg's avatar
eg committed
588
    (emit 'RETURN)
589
    (emit-label lab)
Erick's avatar
Erick committed
590

591 592 593
    (when doc
      ;; emit the docstring
      (emit 'DOCSTRG (fetch-constant doc)))))
eg's avatar
eg committed
594 595 596 597


;;; EXTENDED LAMBDAS
;;;
Erick's avatar
Erick committed
598
;;; This code is an adaptation of the contribution of Ian Wild <imw@acm.org>
eg's avatar
eg committed
599 600 601 602 603 604 605 606 607 608 609 610 611 612
;;; which provided Common Lisp style lambda lists for the original STk.
(define ext-lambda-key-get key-get)

(define (build-let* opt key rest-name user-visible-rest body)
  ;; Create a (LET*...) to do the actual bindings

  (define (pop x)
    (let ((pop-local-variable (gensym)))
      `(let ((,pop-local-variable (car ,x)))
	 (set! ,x (cdr ,x))
	 ,pop-local-variable)))


  (define (build-optional-let-header vars rest-name)
Erick's avatar
Erick committed
613
    (apply append
eg's avatar
eg committed
614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647
	   (map (lambda (x)
		  (let ((var  (car x))
			(init (cadr x))
			(var? (caddr x)))
		    ;; if we have keywords, the end of optional
		    ;; happens when we encounter the end of the
		    ;; parameter list or the first keyword
		    (if key
			;; function accepts keywords
			(cond
			  (var? `((,var? (and (pair? ,rest-name)
					      (not (keyword? (car ,rest-name)))))
				  (,var ,(if init
					     `(if ,var? ,(pop rest-name) ,init)
					     `(and ,var? ,(pop rest-name))))))
			  (init `((,var (if (or (null? ,rest-name)
						(keyword? (car ,rest-name)))
					    ,init
					    ,(pop rest-name)))))
			  (else `((,var (and (pair? ,rest-name)
					     (not (keyword? (car ,rest-name)))
					     ,(pop rest-name))))))
			;; function has optionals but no keywords
			(cond
			  (var? `((,var? (pair? ,rest-name))
				  (,var ,(if init
					     `(if ,var? ,(pop rest-name) ,init)
					     `(and ,var? ,(pop rest-name))))))
			  (init `((,var (if (null? ,rest-name)
					    ,init
					    ,(pop rest-name)))))
			  (else `((,var (and (pair? ,rest-name)
					     ,(pop rest-name)))))))))
		  vars)))
Erick's avatar
Erick committed
648

eg's avatar
eg committed
649 650 651 652 653 654 655
   (define (constant? e)
     (cond
        ((symbol? e) #f)
	((pair? e)   (memq (car e) '(quote lambda)))
	(else 	     #t)))

   (define (build-keyword-let-header vars rest-name)
Erick's avatar
Erick committed
656
     (apply append
eg's avatar
eg committed
657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672
	    (map (lambda (x)
		   (let* ((var  (car x))
			  (init (cadr x))
			  (var? (caddr x))
			  (key  (make-keyword var)))
		     (cond
		        (var? (let ((g (gensym)))
				`((,g (key-get ,rest-name ,key ',g))
				  (,var? (not (eq? ,g ',g)))
				  (,var ,(if init
					     `(if ,var? ,g ,init)
					     `(and ,var? ,g))))))
			((constant? init)
			    ;; if evaluating the initform is harmless, just
			    ;; call key-get with it as default
			    `((,var (key-get ,rest-name ,key ,init))))
Erick's avatar
Erick committed
673
			(else
eg's avatar
eg committed
674 675 676 677 678 679 680
			     ;; only evaluate initform if get-keyword returns
			     ;; our newly gensym'ed symbol
			     (let ((g (gensym)))
			       `((,g (key-get ,rest-name ,key ',g))
				 (,var (if (eq? ,g ',g) ,init ,g))))))))
		 vars)))

Erick's avatar
Erick committed
681 682

  (let ((error-check (if (or user-visible-rest key)
eg's avatar
eg committed
683 684 685
			 '()
			 `((if (pair? ,rest-name)
			       (error "too many optional parameters: ~a"
686 687 688
				      ,rest-name)))))
	(vars (append (if opt (build-optional-let-header opt rest-name) '())
		      (if key (build-keyword-let-header key rest-name) '()))))
eg's avatar
eg committed
689 690 691
    `(let* (,@(if opt (build-optional-let-header opt rest-name) '())
	    ,@(if key (build-keyword-let-header key rest-name) '()))
       ,@error-check
692
       (let () ,@body))))
eg's avatar
eg committed
693 694 695 696 697 698 699 700 701 702 703 704 705 706

(define (parse-parameter-list method? x)
  ;; Read the incoming lambda (or method) list, return a list of four lists,
  ;; the required, optional, keyword, and rest, in that order.
  ;; The last three elements can be #f if not present.
  ;; (Don't look too closely, this function isn't very nice.)
  (define required '())
  (define optional '())
  (define keywords '())
  (define rest 	   '())
  (define epair    x)


  (define (normalise-parameter-list x optional?)
Erick's avatar
Erick committed
707 708
    ;; Convert optional or keyword parameters to three-element lists:
    ;; (variable initform supplied-p), providing an  explicit #f
eg's avatar
eg committed
709 710 711
    ;; initform  if needed, and maybe another #f as supplied-p.
    (and (pair? x)
	 (map (lambda (e)
Erick's avatar
Erick committed
712
		(cond
eg's avatar
eg committed
713 714 715 716 717 718 719 720
		  ((symbol? e)		 	(list e #f #f))
		  ((and (pair? e)
			(= (length e) 2)
			(symbol? (car e))) 	(append e (list #f)))
		  ((and (pair? e)
			(= (length e) 3)
			(symbol? (car e))
			(symbol? (caddr e))) 	e)
Erick's avatar
Erick committed
721
		  (else (compiler-error 'lambda epair "illegal ~a parameter: ~a"
eg's avatar
eg committed
722 723 724
					(if optional? "optional" "keyword") e)
			(list (gensym) #f #f))))
	      x)))
Erick's avatar
Erick committed
725

eg's avatar
eg committed
726 727 728 729 730 731 732
  (define (collect-sequence)
    (let loop ((seq '()) (still-left x))
      (if (or (null? still-left) (memq (car still-left) '(:optional :key :rest)))
	  (begin
	    (set! x still-left)
	    (reverse seq))
	  (loop (cons (car still-left) seq) (cdr still-left)))))
Erick's avatar
Erick committed
733

eg's avatar
eg committed
734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771
  (define (collect-titled-sequence title)
    (if (and (not (null? x)) (eq? (car x) title))
	(begin
	  (set! x (cdr x))
	  (collect-sequence))
	#f))

  (define (check-formals l seen)
    (unless (null? l)
      (let ((param (car l)))
	(cond
	   ((symbol? param)
		    (if (memq param seen)
			(compiler-error (void) epair "duplicate parameter ~S" param)
			(check-formals (cdr l) (cons param seen))))
	   ((and method? (list? param) (= (length param) 2))
	    	    (if (symbol? (cadr param))
			(and (check-formals (list (car param)) seen)
			     (check-formals (cdr l) (cons (car param) seen)))
			(compiler-error (void) epair "bad class name ~S" param)))
	   (else    (compiler-error (void) epair
				     "bad procedure parameter ~S" param))))))


  ;; If the original lambda list is *not* a proper list, i.e. a symbol
  ;; or a dotted list, add in the implied :rest
  (unless (list? x)
    (set! x (if (pair? x)
		(let* ((new-x (copy-tree x))
		       (last  (last-pair new-x)))
		  (set-cdr! last (list :rest (cdr last)))
		  new-x)
		(list :rest x))))

  (set! required (collect-sequence))
  (set! optional (normalise-parameter-list (collect-titled-sequence :optional) #t))
  (set! rest 	 (collect-titled-sequence :rest))
  (set! keywords (normalise-parameter-list (collect-titled-sequence :key) #f))
Erick's avatar
Erick committed
772

eg's avatar
eg committed
773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808
  ;; Do some checks on the arguments
  ;; 1. no un-analyzed parameter
  (unless (null? x)
    (compiler-error 'lambda epair "illegal lambda list ending with ~a" x))

  ;; 2. Rest is a symbol (collect returns a list)
  (when rest
    (unless (and (= (length rest) 1) (symbol? (car rest)))
      (compiler-error 'lambda epair "rest parameter must be a single symbol"))
    (set! rest (car rest)))

  ;; 3. Every formal is a symbol and there is no duplicate
  (check-formals (append (if optional (map car optional) '())
			 (if keywords (map car keywords) '())
			 (if rest     (list rest)        '())
			 required)
		 '())
  ;; OK, let's go
  (list required optional keywords rest))


(define (rewrite-params-and-body method? formals body)
  ;; Rewrite the extended form as an ordinary (though headless) lambda form.
  ;; In a spurious attempt at efficiency, no LET* is generated
  ;; unless at least one of :optional and :key is used.
  (let* ((params (parse-parameter-list method? formals))
	 (req 	 (car params))
	 (opt 	 (cadr params))
	 (key 	 (caddr params))
	 (rest 	 (cadddr params)))
    (if (or opt key)
	;; We have a :optional or a :key keyword
	(let ((rest-name (or rest (gensym))))
	  (if (null? req)					; FIXME: simpl
	      (set! req rest-name)
	      (set-cdr! (last-pair req) rest-name))
809
	  `(,req  ,(build-let* opt key rest-name rest body)))
eg's avatar
eg committed
810 811 812 813 814
	;; "Normal" lambda
	(begin (if rest
		   (if (null? req)
		       (set! req rest)
		       (set-cdr! (last-pair req) rest)))
815
	       `(,req  ,@body)))))
Erick's avatar
Erick committed
816

eg's avatar
eg committed
817 818
(define (extended-lambda->lambda el)	;; STklos lambda => R5RS lambda
  (if (> (length el) 2)
819 820 821 822 823 824 825 826 827 828 829 830
      (let* ((method? (eq? (car el) 'method))
	     (formals (cadr el))
	     (body    (cddr el))
	     (doc     (and (> (length body) 1) (string? (car body)) (car body)))
	     (new     (rewrite-params-and-body method?
					       formals
					       (if doc (cdr body) body))))
	(if doc
	    `(lambda ,(car new)
	       ,doc
	       ,@(cdr new))
	    `(lambda ,@new)))
eg's avatar
eg committed
831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875
      (compiler-error 'lambda el "bad definition ~S" el)))


(define (compile-lambda args env tail?)
  (let* ((r5rs-lambda (extended-lambda->lambda args))
	 (formals     (cadr r5rs-lambda))
	 (body        (cddr r5rs-lambda))
	 (arity       (compute-arity formals)))
    (compile-user-lambda formals body arity env)))

;;;;
;;;; APPLICATION
;;;;

(define (compile-args actuals env)
  (unless (null? actuals)
    (compile (car actuals) env actuals #f)
    (emit 'PUSH)
    (compile-args (cdr actuals) env)))


(define (compile-var-args actuals number-of-fix env)
  ;; for a (a b . c), replace (1 2 3 4 5) by (1 2 (list 3 4 5))
  (let loop ((n number-of-fix) (f '()) (rest actuals))
    (if (zero? n)
	(compile-args `(,@(reverse f) (list ,@rest)) env)
	(loop (- n 1) (cons (car rest) f) (cdr rest)))))

(define (generate-PREPARE-CALL epair)
  (emit 'PREPARE-CALL)
  (when (and (compiler:gen-line-number) (%epair? epair))
    ;; Generate a line number for the call
    (compile-constant (%epair-file epair) '() #f)
    (emit 'PUSH)
    (compile-constant (%epair-line epair) '() #f)
    (emit 'DBG-VM 1)))


(define (compile-normal-call fct actuals len env epair tail?)
  (generate-PREPARE-CALL epair)
  (compile-args actuals env)
  (compile fct env actuals #f)
  (emit (if tail? 'TAIL-INVOKE  'INVOKE)
	(length actuals)))

876 877 878 879 880 881 882 883 884
(define can-be-inlined?
  (let ((STklos (find-module 'STklos)))
    (lambda (fct env)
      ;; Avoid to use *inline-table* on all symbols (assoc is too expensive here)
      (if (and (memq fct *inline-symbols*)
	       (not (symbol-in-env? fct env)))
	  (let ((f (assoc fct *inline-table*)))
	    (and f (eq? (symbol-value* fct STklos) (cdr f))))
	  (memq fct *always-inlined*)))))
eg's avatar
eg committed
885 886 887 888 889 890 891 892 893 894 895


(define (compile-primitive-call fct actuals len env epair tail?)
  (let ((comp  (lambda (mnemo expr)
		 (compile expr env epair #f)
		 (emit mnemo)))
	(comp1 (lambda (mnemo)
		 (if (= len 1)
		     (begin
		       (compile (car actuals) env epair #f)
		       (emit mnemo))
Erick's avatar
Erick committed
896
		     (compiler-error fct epair "1 argument required (~A provided)"
eg's avatar
eg committed
897 898 899 900 901 902 903 904 905 906
				    len))))
	(comp2 (lambda (mnemo)
		 (if (= len 2)
		     (begin
		       (compile (car actuals) env epair #f)
		       (emit 'PUSH)
		       (compile (cadr actuals) env epair #f)
		       (emit mnemo))
		     (compiler-error fct epair "2 arguments required (~A provided)"
				    len))))
907 908 909 910 911 912 913 914
	(oper2 (lambda (mnemo a b)
		 (compile a env epair #f)
		 (emit mnemo b)))
	(komp2 (lambda (mnemo a b)
		 (compile a env epair #f)
		 (emit 'PUSH)
		 (compile b env epair #f)
		 (emit mnemo)))
eg's avatar
eg committed
915 916
	(comp3 (lambda (mnemo)
		 (if (= len 3)
Erick's avatar
Erick committed
917
		     (begin
eg's avatar
eg committed
918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935
		       (compile (car actuals) env epair #f)
		       (emit 'PUSH)
		       (compile (cadr actuals) env epair #f)
		       (emit 'PUSH)
		       (compile (caddr actuals) env epair #f)
		       (emit mnemo))
		     (compiler-error fct epair "3 arguments required (~A provided)"
				     len)))))
    (case fct
      ;; Always inlined functions
      ((%%set-current-module)
       	      (if (= len 1)
		  (comp1 'SET-CUR-MOD)
		  (compiler-error '%%set-current-module epair
				   "1 arg. only (~S)" len)))
      ((%%execute-handler)
       	      (comp3 'EXEC-HANDLER))

Erick's avatar
Erick committed
936
      ;; User functions
eg's avatar
eg committed
937
      ((void) (emit 'IM-VOID))
938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955
      ((+)  (case len
	      ((0)  (emit 'IM-ZERO))
	      ((1)  (compile (car actuals) env epair tail?))
	      ((2)  (let ((a (car actuals))
			  (b (cadr actuals)))
		      (cond
			((and (number? a) (number? b))
			 (compile-constant (+ a b) env #f))
			((small-integer-constant? a)
			 (oper2 'IN-SINT-ADD2 b a))
			((small-integer-constant? b)
			 (oper2 'IN-SINT-ADD2 a b))
			(else
			 (comp2 'IN-ADD2)))))
	      (else (compile-normal-call fct actuals len env epair #f))))
      ((-)  (case len
		((0)  (compiler-error '- epair "needs at least one argument"))
		((1)  (if (number? (car actuals))
Erick Gallesio's avatar
.  
Erick Gallesio committed
956
			  (compile-constant (- (car actuals)) env #f)
957 958 959 960 961 962 963 964 965 966 967 968 969
			  (compile-normal-call fct actuals len env epair #f)))
		((2)  (let ((a (car actuals))
			    (b (cadr actuals)))
			(cond
			  ((and (number? a) (number? b))
			   (compile-constant (- a b) env tail?))
			  ((small-integer-constant? a)
			   (oper2 'IN-SINT-SUB2 b a))
			  ((and (number? b)
				(small-integer-constant? (- b)))
			   (oper2 'IN-SINT-ADD2 a (- b)))
			  (else
			   (comp2 'IN-SUB2)))))
eg's avatar
eg committed
970 971 972
		(else (compile-normal-call fct actuals len env epair #f))))
      ((*)    (case len
		((0)  (emit 'IM-ONE))
973 974 975 976 977 978 979 980 981
		((1)  (compile (car actuals) env epair tail?))
		((2)  (let ((a (car actuals))
			    (b (cadr actuals)))
			(cond
			  ((and (number? a) (number? b))
			   (compile-constant (* a b) env tail?))
			  ((small-integer-constant? a)
			   (oper2 'IN-SINT-MUL2 b a))
			  ((small-integer-constant? b)
Erick Gallesio's avatar
Erick Gallesio committed
982
			   (oper2 'IN-SINT-MUL2 a b))
983 984
			  (else
			   (comp2 'IN-MUL2)))))
eg's avatar
eg committed
985 986 987
		(else (compile-normal-call fct actuals len env epair #f))))
      ((/)    (case len
		((0)   (compiler-error '/ epair "needs at least one argument"))
988
		((1)   (if (number? (car actuals))
Erick Gallesio's avatar
.  
Erick Gallesio committed
989
			  (compile-constant (/ 1 (car actuals)) env #f)
990 991 992 993 994 995 996
			  (compile-normal-call fct actuals len env epair #f)))
		((2)  (let ((a (car actuals))
			    (b (cadr actuals)))
			(cond
			  ((and (number? a) (number? b))
			   (compile-constant (/ a b) env tail?))
			  ((small-integer-constant? b)
Erick Gallesio's avatar
Erick Gallesio committed
997
			   (oper2 'IN-SINT-DIV2 a b))
998 999
			  (else
			   (comp2 'IN-DIV2)))))
eg's avatar
eg committed
1000
		(else  (compile-normal-call fct actuals len env epair #f))))
Erick Gallesio's avatar
Erick Gallesio committed
1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015
      ((fx+ fx- fx* fxdiv)
                (case len
		  ((2) (let ((a (car actuals))
			     (b (cadr actuals)))
			 (cond
			   ((and (fixnum? a) (fixnum? b))
			    (compile-constant (case fct
						((fx+) (fx+ a b))
						((fx-) (fx- a b))
						((fx*) (fx* a b))
						((fxdiv) (fxdiv a b)))
					      env
					      tail?))
			   ((and (small-integer-constant? a)
				 (memq fct '(fx+ fx*)))	; commutative only
Erick Gallesio's avatar
Erick Gallesio committed
1016 1017
			    (oper2 (if (eq? fct 'fx+)
				       'IN-SINT-FXADD2
1018
				       'IN-SINT-FXMUL2)
Erick Gallesio's avatar
Erick Gallesio committed
1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034
				   b a))
			   ((small-integer-constant? b)
			    (oper2 (case fct
				     ((fx+)   'IN-SINT-FXADD2)
				     ((fx-)   'IN-SINT-FXSUB2)
				     ((fx*)   'IN-SINT-FXMUL2)
				     ((fxdiv) 'IN-SINT-FXDIV2))
				   a b))
			   (else
			    (comp2 (case fct
				     ((fx+)   'IN-FXADD2)
				     ((fx-)   'IN-FXSUB2)
				     ((fx*)   'IN-FXMUL2)
				     ((fxdiv) 'IN-FXDIV2)))))))
		  (else
		   (compile-normal-call fct actuals len env epair #f))))
Erick's avatar
Erick committed
1035

eg's avatar
eg committed
1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080
      ((= < > <= >=)
		(case len
		((O)   (compiler-error fct epair
					"needs at least one argument" fct))
		((2)   (comp2 (case fct
				((=)  'IN-NUMEQ)
				((<)  'IN-NUMLT)
				((>)  'IN-NUMGT)
				((<=) 'IN-NUMLE)
				((>=) 'IN-NUMGE))))
		(else  (compile-normal-call fct actuals len env epair #f))))
      ((cons)   (comp2 'IN-CONS))
      ((car)    (comp1 'IN-CAR))
      ((cdr)    (comp1 'IN-CDR))
      ((null?)  (comp1 'IN-NULLP))
      ((not)    (comp1 'IN-NOT))
      ((list)   (compile-args actuals env)
	        (emit 'IN-LIST len))
;;//      ((apply)  (case len
;;//		  ((0)  (compile-error "no argument given to apply"))
;;//		  ((1)  (compile-primitive-call fct (list (car actuals) '())
;;//						(+ len 1) env tail?))
;;//		  (else (emit 'PREPARE-CALL)
;;//			(compile-args (cdr actuals) env)
;;//			(compile (car actuals) env #f)
;;//			(emit 'IN-APPLY (- len 1) (if tail? 1 0)))))
      ((vector-ref)	(comp2 'IN-VREF))
      ((vector-set!)	(comp3 'IN-VSET))
      ((string-ref)	(comp2 'IN-SREF))
      ((string-set!)	(comp3 'IN-SSET))
      ((eq?)		(comp2 'IN-EQ))
      ((eqv?)		(comp2 'IN-EQV))
      ((equal?)		(comp2 'IN-EQUAL))
      (else     	(panic "unimplemented inline primitive ~S" fct)))))



(define (compile-lambda-call fct actuals len env epair tail?)
  ;; Compilation of ( [LAMBDA(.)...] ..... )
  (let* ((fct     (extended-lambda->lambda fct))
	 (formals (cadr fct))
	 (body    (cddr fct))
	 (arity   (compute-arity formals)))
    (if (or (= arity len)
	    (and (negative? arity) (>= len (- (- arity) 1))))
1081 1082
	(let ((kind    (if tail? 'ENTER-TAIL-LET 'ENTER-LET))
	      (new-env (extend-env env formals)))
eg's avatar
eg committed
1083 1084 1085 1086 1087 1088 1089 1090
	  (generate-PREPARE-CALL epair)
	  (if (negative? arity)
	      (begin
		(compile-var-args actuals (- (- arity) 1) env)
		(emit kind (- arity)))
	      (begin
		(compile-args actuals env)
		(emit kind len)))
1091
	  (compile-body body new-env epair tail?)
eg's avatar
eg committed
1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102
	  (emit (if tail? 'RETURN 'LEAVE-LET)))
	(compiler-error 'lambda epair "bad number of parameters ~S" actuals))))


(define (compile-call args env tail?)
  (let* ((fct 	  (car args))
	 (actuals (cdr args))
	 (len 	  (length actuals)))
    (if (and (pair? fct) (eq? (car fct) 'lambda))
	;; fct is (lambda (...) ...)
	;;    if fct is not an epair, it is probably because it has been
Erick's avatar
Erick committed
1103
	;;    built programmatically. Anyway its body is probably an epair
eg's avatar
eg committed
1104 1105 1106 1107 1108
	(let ((ep (cond
		    ((%epair? fct) fct)
		    ((>= (length fct) 3) (cddr fct))
		    (else fct))))
	  (compile-lambda-call fct actuals len env ep tail?))
1109
	(if (can-be-inlined? fct env)
eg's avatar
eg committed
1110 1111 1112 1113 1114 1115 1116
	    (compile-primitive-call fct actuals len env args tail?)
	    (compile-normal-call    fct actuals len env args tail?)))))

;;;;
;;;; LET / LET* / LETREC
;;;;
(define (valid-let-bindings? bindings unique?)
Erick's avatar
Erick committed
1117
  (letrec
eg's avatar
eg committed
1118
      ((aux (lambda (l seen)
Erick's avatar
Erick committed
1119
	      (cond
eg's avatar
eg committed
1120 1121
	       ((null? l) #t)
	       ((pair? l) (let ((b (car l)))
Erick's avatar
Erick committed
1122
			    (if (and (list? b)
eg's avatar
eg committed
1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144
				     (= (length b) 2)
				     (symbol? (car b)))
				(if (and unique? (memq (car b) seen))
				    (compiler-error 'let bindings
						     "duplicate binding ~S" (car b))
				    (aux (cdr l) (cons (car b) seen)))
				(compiler-error 'let bindings
						 "malformed binding ~S" b))))
	       (else #f)))))
    (aux bindings '())))

;;
;; LETREC
;;

(define (compile-letrec args env tail?)
  (let ((len (length args)))
    (if (< len 3)
	(compiler-error 'letrec args "ill formed letrec ~S" args)
	(let ((bindings (cadr args))
              (body     (cddr args)))
	  (if (null? bindings)
1145
	      (compile-body body env body tail?)
eg's avatar
eg committed
1146 1147 1148 1149 1150 1151 1152
	      (when (valid-let-bindings? bindings #t)
		(let ((tmps (map (lambda (_) (gensym)) bindings)))
		  (compile `(let ,(map (lambda (x) (list (car x) #f)) bindings)
			      (let ,(map (lambda (x y) (list x (cadr y)))
					 tmps bindings)
				,@(map (lambda (x y) `(set! ,(car y) ,x))
				       tmps bindings))
1153
			      (let () ,@body))
eg's avatar
eg committed
1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182
			   env args tail?))))))))

;;
;; LET (& named let)
;;

(define (compile-named-let name bindings body len args env tail?)
  (if (< len 4)
      (compiler-error 'let args "ill formed named let ~S" args)
      (when (valid-let-bindings? bindings #t)
	(compile `((letrec ((,name (lambda ,(map car bindings) ,@body)))
		       ,name)
		   ,@(map cadr bindings))
		 env
		 args
		 tail?))))


(define (compile-let args env tail?)
  (let ((len (length args)))
    (if (< len 3)
	(compiler-error 'let args "ill formed let ~S" args)
	(let ((bindings (cadr args))
	      (body	(cddr args)))
	  (if (symbol? bindings)
	      ;; Transform named let in letrec
	      (compile-named-let bindings (car body) (cdr body) len args env tail?)
	      (when (valid-let-bindings? bindings #t)
		(if (null? bindings)
1183
		    (compile-body body env args tail?)
eg's avatar
eg committed
1184 1185 1186 1187 1188 1189 1190 1191 1192
		    (compile `((lambda ,(map car bindings) ,@body)
			       ,@(map cadr bindings))
			     env args tail?))))))))

;;
;; LET*
;;

;; Here is a simple version (inefficient) of compile-let*
Erick's avatar
Erick committed
1193
;;
eg's avatar
eg committed
1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206
;;    (define (compile-let* args env tail?)
;;      (let ((len (length args)))
;;        (if (< len 3)
;;    	(compiler-error 'let* args "ill formed let* ~S" args)
;;    	(let ((bindings (cadr args))
;;    	      (body	(cddr args)))
;;    	  (when (valid-let-bindings? bindings #f)
;;    	    (compile (if (<= (length bindings) 1)
;;    			 `(let ,bindings ,@body)
;;    			 `(let (,(car bindings))
;;     			    (let* ,(cdr bindings)
;;    			      ,@body)))
;;    		     env args tail?))))))
Erick's avatar
Erick committed
1207
;;
eg's avatar
eg committed
1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221

(define (compile-let* args env tail?)
  ;; This is a little bit tricky
  ;; We have something like
  ;; (let ((a E1) (b E2)) ...) =>
  ;;              (let ((a #f) (b #f))          [1]
  ;;                (set! a E1) (set! b E2)	[2]
  ;;                 ...)			[3]
  ;;
  ;; For [1], we have 2 special instructions which reserve space on the stack
  ;; For [2], this is a little bit more complicate since E1 must be evaluated
  ;; in an environment without a, E2 must be evaluated in an environment with
  ;; a and without b
  ;; [3] must be evaluated in an environment where a and b are defined;
Erick's avatar
Erick committed
1222
  ;;
eg's avatar
eg committed
1223 1224 1225 1226 1227 1228 1229 1230 1231 1232
  ;; If there are multiple definition of the same variable, it is multi-allocated
  ;; but only one slot will be used. Not a big deal, in general
  (let ((len (length args)))
    (if (< len 3)
	(compiler-error 'let* args "ill formed let* ~S" args)
	(let ((bindings (cadr args))
	      (body	(cddr args)))
	  (when (valid-let-bindings? bindings #f)
	    (if (<= (length bindings) 1)
		(compile-let `(let ,bindings ,@body) env tail?)
Erick's avatar
Erick committed
1233
		(begin
eg's avatar
eg committed
1234 1235 1236 1237 1238 1239
		  (emit (if tail? 'ENTER-TAIL-LET-STAR 'ENTER-LET-STAR)
			(length bindings))
		  (let Loop ((l bindings)
			     (locals '()))
		    (if (null? l)
			;; Compile body
1240
			(let ((new-env (extend-env env locals)))
1241
			  (compile-body body new-env body tail?)
eg's avatar
eg committed
1242 1243 1244 1245 1246 1247 1248 1249 1250
			  (emit (if tail? 'RETURN 'LEAVE-LET)))
			;; Compile an assignment
			(let* ((var (caar l))
			       (val (cadar l))
			       (loc (cons var locals)))
			  (compile val (extend-env env locals) args #f)
			  (compile-access var (extend-env env loc) args #f)
			  (Loop (cdr l)
				loc)))))))))))
Erick's avatar
Erick committed
1251

eg's avatar
eg committed
1252 1253 1254 1255
;;
;; COND
;;
(define (rewrite-cond-clauses c)
Erick's avatar
Erick committed
1256
  (cond
eg's avatar
eg committed
1257 1258 1259 1260 1261 1262
   ((null? c) 		      (void))
   ((not (pair? (car c)))     (compiler-error 'cond c "invalid clause ~S" (car c)))
   ((eq? (caar c) 'else)      (if (null? (cdr c))
				  `(begin ,@(cdar c))
				  (compiler-error 'cond
						   c
Erick's avatar
Erick committed
1263
						   "else not in last clause ~S"
eg's avatar
eg committed
1264 1265 1266 1267 1268 1269 1270 1271 1272 1273
						   c)))
   ((and (pair? (cdar c)) (eq? (cadar c) '=>))
    			      (if (and (list? (car c)) (= (length (car c)) 3))
				  (let ((test-var (gensym)))
				    `(let ((,test-var ,(caar c)))
				       (if ,test-var
					   (,(caddar c) ,test-var)
					   ,(rewrite-cond-clauses (cdr c)))))
				  (compiler-error 'cond
						   c
Erick's avatar
Erick committed
1274
						   "bad '=>' clause syntax ~S"
eg's avatar
eg committed
1275 1276 1277 1278 1279
						   (car c))))
   ((null? (cdar c))	      (let ((test-var (gensym)))
				`(let ((,test-var ,(caar c)))
				   (or ,test-var
				       ,(rewrite-cond-clauses (cdr c))))))
Erick's avatar
Erick committed
1280
   (else 		      `(if ,(caar c)
eg's avatar
eg committed
1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296
				   (begin ,@(cdar c))
				   ,(rewrite-cond-clauses (cdr c))))))

(define (compile-cond e env tail?)
  (let ((new-form (rewrite-cond-clauses (cdr e))))
    (compile new-form env e tail?)))

;;
;; CASE
;;

(define (rewrite-case-clauses key clauses)
  ;; Some controls on the case form
  (let ((all-values '()))
    (for-each (lambda (clause)
		(if (pair? clause)
Erick's avatar
Erick committed
1297 1298
		    (cond
		      ((eq? (car clause) 'else)
eg's avatar
eg committed
1299
		       	   'ok)
Erick's avatar
Erick committed
1300 1301
		      ((pair? (car clause))
		           ;; OK but verify that there are no duplicates
eg's avatar
eg committed
1302 1303 1304 1305
		       	   (for-each (lambda (x)
				       (if (memv x all-values)
					   (compiler-error
					       'case clause
Erick's avatar
Erick committed
1306
					       "duplicate case value ~S in ~S"
eg's avatar
eg committed
1307 1308 1309
					       x clause)))
				     (car clause))
			   (set! all-values (append (car clause) all-values)))
Erick's avatar
Erick committed
1310
		      (else
eg's avatar
eg committed
1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339
		           (compiler-error 'case clause
					   "ill formed case clause ~S" clause)))
		    (compiler-error 'case clauses
				    "invalid clause syntax in ~S" clause)))
	      clauses))

  ;; Generate equivalent cond form
  `(cond ,@(map (lambda (clause)
		  ;; We are not sure it is a well formed clause since
		  ;; previous checks may not call error (file compilation)
		  (if (pair? clause)
		      (let ((case  (car clause))
			    (exprs (cdr clause)))
			(if (eq? case 'else)
			    `(else ,@exprs)
			    (if (pair? case)
				(if (= (length case) 1)
				    `((eqv? ,key ',(car case)) ,@exprs)
				    `((memv ,key ',case) ,@exprs))
				`(#t (error "invalid case clause")))))
		      `(#t (error "invalid case"))))
		clauses)))

(define (compile-case e env tail?)
  (if (> (length e) 2)
      (let* ((key     (cadr e))
	     (clauses (cddr e))
	     (new-form (if (pair? key)
			   (let ((newkey (gensym)))
Erick's avatar
Erick committed
1340
			     `(let ((,newkey ,key))
eg's avatar
eg committed
1341 1342 1343 1344 1345 1346
				,(rewrite-case-clauses newkey clauses)))
			   (rewrite-case-clauses key clauses))))
	(compile new-form env e tail?))
      (compiler-error 'case e "no key given")))

;;
Erick's avatar
Erick committed
1347
;; DO
eg's avatar
eg committed
1348 1349 1350 1351 1352 1353
;;
(define (rewrite-do inits test body)
  (let ((loop-name (gensym)))
    `(letrec ((,loop-name
       (lambda ,(map car inits)
	 (if ,(car test)
Erick's avatar
Erick committed
1354
	     (begin ,@(if (null? (cdr test))
eg's avatar
eg committed
1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384
			  (list (void))
			  (cdr test)))
	     (begin ,@body
		    (,loop-name ,@(map (lambda (init)
					 (if (< (length init) 2)
					     (compiler-error 'do
							      init
							      "bad binding ~S"
							      init)
					     (if (null? (cddr init))
						 (car init)
						 (caddr init))))
				       inits)))))))
       (,loop-name ,@(map cadr inits)))))


(define (compile-do e env tail?)
  (if (>= (length e) 3)
      (compile (rewrite-do (cadr e) (caddr e) (cdddr e))
	       env
	       e
	       #f)
      (compiler-error 'do e "bad syntax")))

;;
;; QUASIQUOTE
;;

(define (backquotify e level)
  (cond
Erick's avatar
Erick committed
1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416
    ((pair? e)
       (cond
	 ((eq? (car e) 'quasiquote)
	       (list 'list ''quasiquote
		     (backquotify (cadr e) (+ level 1))))
	 ((eq? (car e) 'unquote)
	       (if (<= level 0)
		   (cadr e)
		   (list 'list ''unquote
			 (backquotify (cadr e) (- level 1)))))
	 ((eq? (car e) 'unquote-splicing)
	      (if (<= level 0)
		  (list 'cons
			(backquotify (car e) level)
			(backquotify (cdr e) level))
		  (list 'list ''unquote-splicing
			(backquotify (cadr e) (- level 1)))))
	 ((and (<= level 0) (pair? (car e)) (eq? (caar e) 'unquote-splicing))
	      (if (null? (cdr e))
		  (cadar e)
		  (list 'append (cadar e)
			(backquotify (cdr e) level))))
	 (else
	      (list 'cons
		    (backquotify (car e) level)
		    (backquotify (cdr e) level)))))
    ((vector? e)
       (list 'list->vector (backquotify (vector->list e) level)))
    ((symbol? e)
       (list 'quote e))
    (else
       e)))
eg's avatar
eg committed
1417 1418 1419

(define (compile-quasiquote e env tail?)
  (if (= (length e) 2)
Erick's avatar
Erick committed
1420
      (compile (backquotify (cadr e) 0) env e tail?)
eg's avatar
eg committed
1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446
      (compiler-error 'quasiquote e "bad syntax")))


;;
;; WITH-HANDLER
;;
(define (compile-with-handler e env tail?)
  (if (> (length e) 2)
      (let ((handler (cadr e))
	    (body    (cddr e))
	    (lab     (new-label)))
	(compile handler env e #f)
	(emit 'PUSH-HANDLER lab)
	(compile `(begin ,@body) env body #f)
	(emit 'POP-HANDLER)
	(emit-label lab))
      (compiler-error 'with-handler e "bad syntax")))


;;
;; INCLUDE
;;

#|
<doc EXT-SYNTAX include
 * (include <file>)
Erick's avatar
Erick committed
1447
 *
eg's avatar
eg committed
1448 1449 1450 1451 1452 1453 1454 1455
 * TODO
doc>
|#
(define (include-file name)
  (let ((port (open-input-file name))
	(old  *compiler-port*))
    (with-handler (lambda (c) (set! *compiler-port* old) (raise c))
		  (set! *compiler-port* port)
Erick's avatar
Erick committed
1456

eg's avatar
eg committed
1457 1458 1459
		  (do ((expr (%read port) (%read port)))
		      ((eof-object? expr))
		    (compile expr '() expr #f))
Erick's avatar
Erick committed
1460

eg's avatar
eg committed
1461 1462 1463 1464 1465 1466 1467 1468 1469 1470
		  (set! *compiler-port* old))
    (close-port port)))

(define (compile-include e env tail)
  (if (and (= (length e) 2) (string? (cadr e)))
      (include-file (cadr e))
      (compiler-error 'include e "bad include directive ~S" e)))


;;
Erick's avatar
Erick committed
1471
;; Autoloads management
eg's avatar
eg committed
1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485
;;
(define (compiler-maybe-do-autoload symb)
  (let ((file (autoload-file symb)))
    (when file
      ;; Do the autoload
      (let ((old-code *code-instr*)
	    (old-cst  *code-constants*))
	(remove-autoload! symb)
	(require file)
	(set! *code-instr* old-code)
	(set! *code-constants* old-cst)))))

;;;;======================================================================
;;;;
Erick's avatar
Erick committed
1486 1487
;;;; 		Special Calls
;;;;
eg's avatar
eg committed
1488
;;;;======================================================================
1489 1490 1491

;;;;
;;;; Utilities for REQUIRE / REQUIRE-FOR-SYNTAX
Erick's avatar
Erick committed
1492
;;;;
Erick Gallesio's avatar
Erick Gallesio committed
1493
(define (find-file-informations file lib-only? eventually-compile?)
1494 1495 1496 1497 1498 1499 1500 1501 1502

  (define (compile-and-find-infos path)
    (let ((tmp (temporary-file-name)))
      (compile-file path tmp)
      (let ((infos (%file-informations tmp)))
	(remove-file tmp)
	(set! infos (key-set! infos :nature 'source))
	infos)))

Erick Gallesio's avatar
Erick Gallesio committed
1503 1504 1505 1506 1507 1508
  (let ((path (find-path file
			 (if lib-only?
			     (list (make-path (%library-prefix)
					      "share" "stklos"
					      (version)))
			     (load-path)))))
1509
    (if path
Erick Gallesio's avatar
Erick Gallesio committed
1510 1511 1512 1513 1514 1515 1516 1517
        (let ((infos (%file-informations path)))
	  (if (and eventually-compile?
		   (eq? (key-get infos :nature 'unknown) 'source))
	      ;; We have a source file (i.e. no info, compile it to have them)
	      (parameterize ((compiler:time-display #f))
		 (compile-and-find-infos path))
	      infos))
	'())))
1518

1519

1520 1521 1522
(define (import-file-informations infos)
  (when (pair? infos)
    ;; Register all the global symbols of the file
Erick Gallesio's avatar
Erick Gallesio committed
1523
    (for-each register-new-global! (key-get infos :globals '()))
1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534
    ;; Install the expanders of the required file
    (for-each (lambda (x)
		(let* ((name     (car x))
		       (proc     (cdr x))
		       (expander `(lambda (form e) (apply ,proc (cdr form)))))
		  (install-expander! name (eval expander) proc)))
	      (key-get infos :expanders '()))))

;;;;
;;;; REQUIRE
;;;;
Erick Gallesio's avatar
.  
Erick Gallesio committed
1535 1536 1537 1538 1539
(define (compile-require e env tail)
  ;; Require is not really special (it is in fact compiled as a normal call)
  ;; We just try to add the globals of the file to the list of known
  ;; globals. This is very empiric, but it avoids to add too much false
  ;; warning when compiling a file using another one.
Erick Gallesio's avatar
Erick Gallesio committed
1540 1541 1542 1543
  (when (and (= (length e) 3)
	     (string? (cadr e))
	     (boolean? (caddr e)))
    (let ((infos (find-file-informations (cadr e) (caddr e) #f)))
1544
      (import-file-informations infos)))
Erick Gallesio's avatar
.  
Erick Gallesio committed
1545 1546

  (compile-normal-call (car e) (cdr e) (length e) env e tail))
eg's avatar
eg committed
1547

1548 1549 1550 1551 1552 1553 1554 1555 1556
;;;;
;;;; PUBLISH-SYNTAX
;;;;
(define (compile-%%pubsyntax e env tail)
  (for-each (lambda (x)
	      (if (symbol? x)
		  (expander-published-add! x)
		  (error '%%publish-syntax "bad symbol ~S" x)))
	    (cdr e)))
1557

1558 1559 1560
;;;;
;;;; REQUIRE-FOR-SYNTAX
;;;;
1561 1562 1563 1564 1565 1566
(define (compile-require4syntax e env tail)
   (if  (and (= (length e) 2)
	     (string? (cadr e)))
     (with-handler
         (lambda (c) (eprintf "*** Exception while required-for-syntax ~S\n" e)
		     (raise c))
Erick Gallesio's avatar
Erick Gallesio committed
1567 1568
	 (let ((infos (find-file-informations (cadr e) (load-path) #t)))
	   (import-file-informations infos)
1569 1570 1571 1572
	   (void)))
     (error 'require-for-syntax "bad form ~S" e)))


1573
#;(define (compile-require4syntax e env tail)
1574 1575 1576 1577 1578 1579 1580 1581
  ;; No code is produced here, we only load the file for the compiler
  (with-handler
     (lambda (c)
       (eprintf "*** Exception while evaluation of required syntax ~S\n" e)
       (raise c))
     (require (cadr e))))


1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595
;;;;
;;;; WHEN-COMPILE
;;;;
(define (compile-when-compile e env tail)
  (with-handler (lambda (c)
		  (eprintf "*** Exception on when-compile form of ~S\n" e)
		  (raise c))
     (eval `(begin ,@(cdr e) (void)))))

(define-macro (when-compile . body)
  `(begin
     (%%when-compile ,@body)
     (void)))

Erick Gallesio's avatar
Erick Gallesio committed
1596 1597 1598 1599 1600
(define-macro (when-load-and-compile . body)
  `(begin
     (%%when-compile ,@body)
     ,@body
     (void)))
1601

eg's avatar
eg committed
1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622
(define (compile-%%label e env tail)
  (if (= (length e) 2)
      (emit-label (cadr e))
      (compiler-error '%%label e "bad usage ~S" e)))

(define (compile-%%goto e env tail)
  (if (= (length e) 2)
      (emit 'GOTO (cadr e))
      (compiler-error '%%goto e "bad usage ~S" e)))


(define (compile-%%source-pos e env tail)
  (compile (if (%epair? e)
	       `(cons ,(%epair-file e) ,(%epair-line e))
	       #f)
	   '()
	   e
	   #f))

;;;;======================================================================
;;;;
Erick's avatar
Erick committed
1623 1624
;;;; 		The bytecode compiler
;;;;
eg's avatar
eg committed
1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646
;;;;======================================================================
(define (compile e env epair tail?)
  (if (not (pair? e))
      (if (symbol? e)
	  (begin
	    (compiler-maybe-do-autoload e)
	    (compile-reference e env epair tail?))
	  (compile-constant  e env tail?))
      (begin
	(case (car e)
	  ((if)			(compile-if		e env tail?))
	  ((define)		(compile-define		e env tail?))
	  ((begin)		(compile-begin		e env tail?))
	  ((lambda)		(compile-lambda		e env tail?))
	  ((let)		(compile-let		e env tail?))
	  ((let*)		(compile-let*		e env tail?))
	  ((letrec)		(compile-letrec		e env tail?))
	  ((and)		(compile-and		e env tail?))
	  ((or)			(compile-or		e env tail?))
	  ((cond)		(compile-cond		e env tail?))
	  ((case)		(compile-case		e env tail?))
	  ((do)			(compile-do		e env tail?))
Erick Gallesio's avatar
Erick Gallesio committed
1647
	  ((quote)		(compile-quote		e env tail?))
eg's avatar
eg committed
1648 1649 1650
	  ((quasiquote)		(compile-quasiquote	e env tail?))
	  ((with-handler) 	(compile-with-handler	e env tail?))
	  ((define-macro) 	(compile-define-macro   e env tail?))
Erick Gallesio's avatar
Erick Gallesio committed
1651
	  ((%%set!)		(compile-set!		e env tail?))
Erick's avatar
Erick committed
1652

eg's avatar
eg committed
1653
	  ;; Special calls
Erick Gallesio's avatar
Erick Gallesio committed
1654
	  ((%%require)		(compile-require	e env tail?))
1655
	  ((%%require4syntax)	(compile-require4syntax e env tail?))
1656
	  ((%%when-compile)	(compile-when-compile   e env tail?))
eg's avatar
eg committed
1657 1658 1659 1660
	  ((%%include)		(compile-include	e env tail?))
	  ((%%source-pos)	(compile-%%source-pos   e env tail?))
	  ((%%label)		(compile-%%label	e env tail?))
	  ((%%goto)		(compile-%%goto		e env tail?))
1661
	  ((%%publish-syntax)	(compile-%%pubsyntax	e env tail?))
Erick's avatar
Erick committed
1662

eg's avatar
eg committed
1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674
	  ;; Unmatched cases
	  (else			(let ((first (car e)))
				  (compiler-maybe-do-autoload first)
				  (if (and (symbol? first)
					   (not (symbol-in-env? first env))
					   (expander? first))
				      (compile (macro-expand e) env epair tail?)
				      (compile-call e env tail?))))))))


;=============================================================================
;
1675
; Eval
eg's avatar
eg committed
1676 1677 1678
;
;=============================================================================

1679
(define (eval e :optional env)
eg's avatar
eg committed
1680

1681 1682 1683 1684
  (define (parse-expression e)
    (compile e '() e #f)
    (emit 'END-OF-CODE)
    (assemble (reverse! *code-instr*)))
eg's avatar
eg committed
1685

1686 1687 1688 1689 1690
  (fluid-let ((*code-instr*     '())
	      (*code-constants* '()))
    (let ((code (parse-expression e)))
      ;;(disassemble-code code (current-error-port))
      (%execute code (list->vector *code-constants*) (or env (current-module))))))
eg's avatar
eg committed
1691

1692 1693
;; ======================================================================
(select-module STklos)
1694
(import STKLOS-COMPILER)
1695 1696 1697
(define eval (in-module STKLOS-COMPILER eval))


eg's avatar
eg committed
1698 1699
;;)
; LocalWords:  initform autoload Autoloads