Commit d8cdc953 authored by Erick Gallesio's avatar Erick Gallesio

RAS

parent 11c3b4aa
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 9-Feb-2007 15:11 (eg)
;;;; Last file update: 18-Feb-2007 22:13 (eg)
;;;; Last file update: 28-Feb-2007 18:58 (eg)
;;;;
......@@ -87,16 +87,23 @@
;; ----------------------------------------------------------------------
;; define*
;; @define
;; ----------------------------------------------------------------------
(define-macro (define* . body)
(define-macro (@define . body)
(match-case body
(((?var . ?args) . ?rest)
`(define (,var . ,(%srfi89->ext-lambda-proto args)) ,@rest))
((?var ?value)
`(define ,var ,value))
(else
(error 'define* "bad form ~S" body))))
(error '@define "bad form ~S" body))))
;; ----------------------------------------------------------------------
;; define*
;; ----------------------------------------------------------------------
(define-macro (define* . body)
`(@define ,@body))
;;;
;;; export %srfi89->ext-lambda-proto
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 14-Mar-2001 13:49 (eg)
;;;; Last file update: 23-Feb-2007 16:29 (eg)
;;;; Last file update: 23-Feb-2007 23:04 (eg)
;;;;
;;;
......@@ -270,7 +270,7 @@
(define (find-far-codeop opcode)
(let ((old-mnemo (car (find-instruction-infos opcode))))
(case old-mnemo
((CREATE-CLOSURE) opcode)
((CREATE-CLOSURE) 'CREATE-CLOSURE-FAR)
(else (panic "No FAR version of instruction ~S" old-mnemo)))))
;;;;======================================================================
......@@ -313,9 +313,11 @@
(lambda (x)
(when (pair? x) ;; This is an instruction
(let ((len (length x)))
;; ----------
;; Place the op-code in the code vector
(vector-set! vect pos (car x))
;; ----------
;; Place (eventually) the first parameter in the code vector
(when (> len 1)
(let ((instr (car x))
......@@ -324,21 +326,21 @@
;; replace it with the offset to the destination
(when (use-address? instr)
(set! param1 (- (cdr (assq param1 labs)) pos 2)))
(vector-set! vect (+ pos 1) param1)
;; For instructions using big constants use their FAR version
(unless (small-integer-constant? param1)
(let ((new (find-far-codeop instr)))
(eprintf "FAR ~S ~S ~S\n"
(car (find-instruction-infos instr))
new
param1)))
;; Store the (eventually new) value of param1 in code array
(vector-set! vect (+ pos 1) param1)))
(case new
((CREATE-CLOSURE-FAR)
(vector-set! vect pos (car (info-opcode new)))
(vector-set! vect (+ pos 1) (fetch-constant param1))))))))
;; ----------
;; Place (eventually) the second parameter in the code vector
(when (> len 2)
(unless (small-integer-constant? (caddr x))
(panic "Instruction with a big constant as second parameter ~S"
x))
(panic "Instr. using a big constant as 2nd operand ~S" x))
(vector-set! vect (+ pos 2) (caddr x)))
(when (> len 3)
......@@ -349,20 +351,14 @@
vect)))
(define (display-code c)
(for-each (lambda (x)
(if (integer? x)
(format #t "L~A:" x)
(format #t "\t~A\n" x)))
c)
(newline))
;;
;;(define (display-code c)
;; (for-each (lambda (x)
;; (if (integer? x)
;; (format #t "L~A:" x)
;; (format #t "\t~A\n" x)))
;; c)
;; (newline))
;;;; ======================================================================
;;;;
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 17-Mar-2001 12:11 (eg)
;;;; Last file update: 30-Jan-2007 17:39 (eg)
;;;; Last file update: 28-Feb-2007 16:51 (eg)
;;;;
(select-module STKLOS-COMPILER)
......@@ -50,7 +50,7 @@
(expander-sources-set! '())
;; Defer warning til the end of the compilation of file
(compiler:warn-use-undefined-postpone #t)
;(compiler:warn-use-undefined-postpone #t)
(fluid-let ((*code-instr* '())
(*code-constants* '()))
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 26-Feb-2000 10:47 (eg)
;;;; Last file update: 23-Feb-2007 15:47 (eg)
;;;; Last file update: 28-Feb-2007 16:51 (eg)
;;;;
(define-module STKLOS-COMPILER
......@@ -81,7 +81,7 @@
(define compiler:time-display (make-parameter #t))
(define compiler:gen-line-number (make-parameter #f))
(define compiler:warn-use-undefined (make-parameter #f))
(define compiler:warn-use-undefined-postpone (make-parameter #f))
(define compiler:warn-use-undefined-postpone (make-parameter #t))
(define compiler:inline-common-functions
(let ((inlined *inline-symbols*))
(make-parameter #t
......
This diff is collapsed.
This source diff could not be displayed because it is too large. You can view the blob instead.
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 1-Mar-2000 19:51 (eg)
* Last file update: 23-Feb-2007 16:23 (eg)
* Last file update: 23-Feb-2007 23:01 (eg)
*/
// INLINER values
......@@ -113,6 +113,7 @@ static Inline void set_signal_mask(sigset_t mask)
/* ==== Code access macros ==== */
#define fetch_next() (*(vm->pc)++)
#define fetch_const() (vm->constants[fetch_next()])
#define look_const() (vm->constants[*(vm->pc)])
#define fetch_global() (*(checked_globals[(unsigned) fetch_next()]))
......@@ -1167,15 +1168,15 @@ CASE(CREATE_CLOSURE) {
NEXT1;
}
CASE(CREATE_CLOSURE_FAR) {
/* CREATE_CLOSURE but with a cons instead of 2 integers */
SCM info = fetch_const();
/* CREATE_CLOSURE but with a pc[0] which is a long constant */
SCM offset = look_const();
if (!INTP(offset)) STk_panic("CREATE_CLOSURE_FAR with offset=~S", offset);
if (!CONSP(info) || !INTP(CAR(info)) || !INTP(CDR(info)))
STk_panic("CREATE_CLOSURE_FAR with ~S", info);
vm->env = clone_env(vm->env, vm);
vm->val = STk_make_closure(vm->pc+1, INT_VAL(CAR(info)), INT_VAL(CDR(info)),
vm->val = STk_make_closure(vm->pc+2, INT_VAL(offset)-1, vm->pc[1],
vm->constants, vm->env);
vm->pc += INT_VAL(CAR(info));
vm->pc += INT_VAL(offset) + 1;
NEXT1;
}
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment