*** empty log message ***

module/language/gscheme/spec.scm

@@ -24,6 +24,7 @@
   :use-module (system il ghil)
   :use-module (language r5rs expand)
   :use-module (ice-9 match)
+  :use-module (ice-9 and-let-star)
   :export (gscheme))
 
 
@@ -53,28 +54,28 @@
 (define (translate x) (if (pair? x) (translate-pair x) x))
 
 (define (translate-pair x)
-  (let ((name (car x)) (args (cdr x)))
+  (let ((head (car x)) (rest (cdr x)))
-    (case name
+    (case head
-      ((quote) (cons '@quote args))
+      ((quote) (cons '@quote rest))
       ((define set! if and or begin)
-       (cons (symbol-append '@ name) (map translate args)))
+       (cons (symbol-append '@ head) (map translate rest)))
       ((let let* letrec)
        (match x
 	 (('let (? symbol? f) ((s v) ...) body ...)
 	  `(@letrec ((,f (@lambda ,s ,@(map translate body))))
 		    (,f ,@(map translate v))))
 	 (else
-	  (cons* (symbol-append '@ name)
+	  (cons* (symbol-append '@ head)
 		 (map (lambda (b) (cons (car b) (map translate (cdr b))))
-		      (car args))
+		      (car rest))
-		 (map translate (cdr args))))))
+		 (map translate (cdr rest))))))
       ((lambda)
-       (cons* '@lambda (car args) (map translate (cdr args))))
+       (cons* '@lambda (car rest) (map translate (cdr rest))))
       (else
-       (let ((prim (symbol-append '@ name)))
+       (let ((prim (and (symbol? head) (symbol-append '@ head))))
-	 (if (ghil-primitive? prim)
+	 (if (and prim (ghil-primitive? prim))
-	     (cons prim (map translate args))
+	     (cons prim (map translate rest))
-	     (cons (translate name) (map translate args))))))))
+	     (cons (translate head) (map translate rest))))))))
 
 
 ;;;

module/language/r5rs/expand.scm

@@ -66,6 +66,7 @@
 (define remprop symbol-property-remove!)
 
 (define syncase-module (current-module))
+
 (define (sc-eval x) (eval x syncase-module))
 
 (load "psyntax.scm")

module/language/r5rs/psyntax.boot

@@ -63,6 +63,7 @@
 (define core-eval eval)
 (define (eval x) (core-eval (cadr x) (interaction-environment)))
 
+(debug-set! stack 0)
 (load "psyntax.pp")
 
 (call-with-input-file "psyntax.ss"

module/language/r5rs/psyntax.ss

@@ -2744,7 +2744,8 @@
 ;;; expanded, and the expanded definitions are also residualized into
 ;;; the object file if we are compiling a file.
 (set! sc-expand
-  (let ((user-ribcage
+  (let ((m 'e) (esew '(eval))
+        (user-ribcage
          (let ((ribcage (make-empty-ribcage)))
            (extend-ribcage-subst! ribcage '*top*)
            ribcage)))
@@ -2752,11 +2753,9 @@
            (make-wrap (wrap-marks top-wrap)
              (cons user-ribcage (wrap-subst top-wrap)))))
       (lambda (x)
-	(let ((m 'e)
-	      (esew '(eval)))
         (if (and (pair? x) (equal? (car x) noexpand))
             (cadr x)
-	      (chi-top x null-env user-top-wrap m esew user-ribcage)))))))
+            (chi-top x null-env user-top-wrap m esew user-ribcage))))))
 
 (set! identifier?
   (lambda (x)

module/language/r5rs/spec.scm

@@ -33,21 +33,20 @@
 (define (translate x) (if (pair? x) (translate-pair x) x))
 
 (define (translate-pair x)
-  (let ((name (car x)) (args (cdr x)))
+  (let ((head (car x)) (rest (cdr x)))
-    (case name
+    (case head
-      ((quote) (cons '@quote args))
+      ((quote) (cons '@quote rest))
       ((define set! if and or begin)
-       (cons (symbol-append '@ name) (map translate args)))
+       (cons (symbol-append '@ head) (map translate rest)))
       ((let let* letrec)
-       (cons* (symbol-append '@ name)
+       (cons* (symbol-append '@ head)
-	      (map (lambda (b)
+	      (map (lambda (b) (cons (car b) (map translate (cdr b))))
-		     (cons (car b) (map translate (cdr b))))
+		   (car rest))
-		   (car args))
+	      (map translate (cdr rest))))
-	      (map translate (cdr args))))
       ((lambda)
-       (cons* '@lambda (car args) (map translate (cdr args))))
+       (cons* '@lambda (car rest) (map translate (cdr rest))))
       (else
-       (cons (translate name) (map translate args))))))
+       (cons (translate head) (map translate rest))))))
 
 
 ;;;

module/system/il/macros.scm

@@ -50,19 +50,6 @@
      (let ((sym (make-sym)))
        `(@let ((,sym ,x)) (@if ,sym ,sym (@or ,@rest)))))))
 
-;; (@while TEST BODY...) =>
-;; 
-;;     (@goto L1)
-;; L0: BODY...
-;; L1: (@if TEST (@goto L0) (@void))
-;;; non-R5RS
-(define (@while test . body)
-  (let ((L0 (make-label)) (L1 (make-label)))
-    `(@begin
-       (@goto ,L1)
-       (@label ,L0) ,@body
-       (@label ,L1) (@if ,test (@goto ,L0) (@void)))))
-
 ;; (@cond (TEST BODY...) ...) =>
 ;;
 ;;   (@if TEST
@@ -98,14 +85,14 @@
 
 ;;; 6.2 Numbers
 
-(define (@number? x)   `(@@ number? ,x))
+(define (@number? x)	`((@ Core::number?) ,x))
-(define (@complex? x)  `(@@ complex? ,x))
+(define (@complex? x)	`((@ Core::complex?) ,x))
-(define (@real? x)     `(@@ real? ,x))
+(define (@real? x)	`((@ Core::real?) ,x))
-(define (@rational? x) `(@@ rational? ,x))
+(define (@rational? x)	`((@ Core::rational?) ,x))
-(define (@integer? x)  `(@@ integer? ,x))
+(define (@integer? x)	`((@ Core::integer?) ,x))
 
-(define (@exact? x)    `(@@ exact? ,x))
+(define (@exact? x)	`((@ Core::exact?) ,x))
-(define (@inexact? x)  `(@@ inexact? ,x))
+(define (@inexact? x)	`((@ Core::inexact?) ,x))
 
 (define (@= x y)	`(@@ ee? ,x ,y))
 (define (@< x y)	`(@@ lt? ,x ,y))
@@ -113,15 +100,6 @@
 (define (@<= x y)	`(@@ le? ,x ,y))
 (define (@>= x y)	`(@@ ge? ,x ,y))
 
-(define (@zero? x)     `(@= ,x 0))
-(define (@positive? x) `(@> ,x 0))
-(define (@negative? x) `(@< ,x 0))
-(define (@odd? x)      `(@= (@modulo ,x 2) 1))
-(define (@even? x)     `(@= (@modulo ,x 2) 0))
-
-(define (@max . args)  `(@@ max ,@args))
-(define (@min . args)  `(@@ min ,@args))
-
 (define @+
   (match-lambda*
     (() 0)
@@ -138,25 +116,20 @@
 
 (define @-
   (match-lambda*
-    ((x) `(@@ neg ,x))
+    ((x) `(@@ sub 0 ,x))
     ((x y) `(@@ sub ,x ,y))
     ((x y . rest) `(@@ sub ,x (@+ ,y ,@rest)))))
 
 (define @/
   (match-lambda*
-    ((x) `(@@ rec ,x))
+    ((x) `(@@ div 1 ,x))
     ((x y) `(@@ div ,x ,y))
     ((x y . rest) `(@@ div ,x (@* ,y ,@rest)))))
 
-(define (@abs x) `(@if (@< x 0) (@- x) x))
+(define (@quotient x y) `(@@ quo ,x ,y))
+(define (@remainder x y) `(@@ rem ,x ,y))
+(define (@modulo x y) `(@@ mod ,x ,y))
 
-(define (@quotient x y) `(@@ quotient ,x ,y))
-(define (@remainder x y) `(@@ remainder ,x ,y))
-(define (@modulo x y) `(@@ modulo ,x ,y))
-
-;;; gcd
-;;; lcm
-;;; 
 ;;; numerator
 ;;; denominator
 ;;; 
@@ -165,8 +138,6 @@
 ;;; truncate
 ;;; round
 ;;; 
-;;; rationalize
-;;; 
 ;;; exp
 ;;; log
 ;;; sin
@@ -197,7 +168,7 @@
 ;;;; 6.3.1 Booleans
 
 (define (@not x) `(@@ not ,x))
-(define (@boolean? x) `(@@ boolean? ,x))
+(define (@boolean? x) `((@ Core::boolean?) ,x))
 
 ;;;; 6.3.2 Pairs and lists
 
@@ -245,8 +216,6 @@
 ;;; length
 ;;; append
 ;;; reverse
-;;; list-tail
-;;; list-ref
 ;;; 
 ;;; memq
 ;;; memv
@@ -270,74 +239,34 @@
 ;;; char>?
 ;;; char<=?
 ;;; char>=?
-;;; char-ci=?
-;;; char-ci<?
-;;; char-ci>?
-;;; char-ci<=?
-;;; char-ci>=?
-;;; char-alphabetic?
-;;; char-numeric?
-;;; char-whitespace?
-;;; char-upper-case?
-;;; char-lower-case?
 ;;; char->integer
 ;;; integer->char
-;;; char-upcase
-;;; char-downcase
 
 ;;;; 6.3.5 Strings
 
 ;;; string?
 ;;; make-string
-;;; string
 ;;; string-length
 ;;; string-ref
 ;;; string-set!
-;;; 
-;;; string=?
-;;; string-ci=?
-;;; string<?
-;;; string>?
-;;; string<=?
-;;; string>=?
-;;; string-ci<?
-;;; string-ci>?
-;;; string-ci<=?
-;;; string-ci>=?
-;;; 
-;;; substring
-;;; string-append
-;;; string->list
-;;; list->string
-;;; string-copy
-;;; string-fill!
 
 ;;;; 6.3.6 Vectors
 
 ;;; vector?
 ;;; make-vector
-;;; vector
 ;;; vector-length
 ;;; vector-ref
 ;;; vector-set!
-;;; vector->list
-;;; list->vector
-;;; vector-fill!
 
 ;;;; 6.4 Control features
 
-(define (@procedure? x) `(@@ procedure? x))
+;; (define (@procedure? x) `(@@ procedure? x))
 
 ;; (define (@apply proc . args) ...)
 
-;;; map
-;;; for-each
-
 ;;; (define (@force promise) `(@@ force promise))
 
-;;; (define (@call-with-current-continuation proc) `(@@ call/cc proc))
+;;; (define (@call/cc proc) `(@@ call/cc proc))
-
-;;; (define @call/cc @call-with-current-continuation)
 
 ;;; values
 ;;; call-with-values
@@ -345,26 +274,15 @@
 
 ;;; 6.5 Eval
 
-;;; eval
-;;; scheme-report-environment
-;;; null-environment
-;;; interaction-environment
-
 ;;; 6.6 Input and output
 
 ;;;; 6.6.1 Ports
 
-;;; call-with-input-file
-;;; call-with-output-file
-;;; 
 ;;; input-port?
 ;;; output-port?
 ;;; current-input-port
 ;;; current-output-port
 ;;; 
-;;; with-input-from-file
-;;; with-output-to-file
-;;; 
 ;;; open-input-file
 ;;; open-output-file
 ;;; close-input-port
@@ -387,10 +305,6 @@
 
 ;;;; 6.6.4 System interface
 
-;;; load
-;;; transcript-on
-;;; transcript-off
-
 
 ;;;
 ;;; Non-R5RS Procedures
@@ -401,8 +315,3 @@
     ((x) x)
     ((x y) `(@cons ,x ,y))
     ((x y . rest) `(@cons ,x (@cons* ,y ,@rest)))))
-
-(define (@error . args) `(@@ display ,@args))
-
-(define (@current-module)
-  `((@ System::Base::module::current-module)))

module/system/vm/assemble.scm

@@ -238,12 +238,14 @@
       (push-code! `(link/current-module)))
      ;;((vmod? x)
      ;;  (push-code! `(load-module ,(vmod-id x))))
-     ((integer? x)
+     ((and (integer? x) (exact? x))
       (let ((str (do ((n x (quotient n 256))
 		      (l '() (cons (modulo n 256) l)))
 		     ((= n 0)
 		      (list->string (map integer->char l))))))
 	(push-code! `(load-integer ,str))))
+     ((number? x)
+      (push-code! `(load-number ,(number->string x))))
      ((string? x)
       (push-code! `(load-string ,x)))
      ((symbol? x)

module/system/vm/conv.scm

@@ -23,7 +23,8 @@
   :use-module (system vm core)
   :use-module (ice-9 match)
   :use-module (ice-9 regex)
-  :export (code-pack code-unpack object->code code->object code->bytes))
+  :export (code-pack code-unpack object->code code->object code->bytes
+		     make-byte-decoder))
 
 ;;;
 ;;; Code compress/decompression
@@ -62,7 +63,7 @@
   (cond ((eq? x #t) `(make-true))
 	((eq? x #f) `(make-false))
 	((null? x) `(make-eol))
-	((integer? x)
+	((and (integer? x) (exact? x))
 	 (cond ((and (<= -128 x) (< x 128))
 		`(make-int8 ,(modulo x 256)))
 	       ((and (<= -32768 x) (< x 32768))
@@ -104,7 +105,7 @@
 	  (else
 	   (error "Invalid code:" code)))))
 
-(define-public (make-byte-decoder bytes)
+(define (make-byte-decoder bytes)
   (let ((addr 0) (size (string-length bytes)))
     (define (pop)
       (let ((byte (char->integer (string-ref bytes addr))))
@@ -135,17 +136,16 @@
 
 (define (encode-length len)
   (define C integer->char)
-  (list->string
+  (cond ((< len 254) (string (C len)))
-   (cond ((< len 254) (list (C len)))
 	((< len (* 256 256))
-	  (list (C 254) (C (quotient len 256)) (C (modulo len 256))))
+	 (string (C 254) (C (quotient len 256)) (C (modulo len 256))))
 	((< len most-positive-fixnum)
-	  (list (C 255)
+	 (string (C 255)
 		 (C (quotient len (* 256 256 256)))
 		 (C (modulo (quotient len (* 256 256)) 256))
 		 (C (modulo (quotient len 256) 256))
 		 (C (modulo len 256))))
-	 (else (error "Too long code length:" len)))))
+	(else (error "Too long code length:" len))))
 
 (define (decode-length pop)
   (let ((len (pop)))

module/system/vm/disasm.scm

@@ -63,7 +63,7 @@
 	     (set! rest (acons sym x rest))
 	     (print-info addr (format #f "load-program #~A" sym) #f)))
 	  (else
-	   (let ((info (list->string code))
+	   (let ((info (list->info code))
 		 (extra (original-value addr code
 					(if (null? opt) #f (car opt)))))
 	     (print-info addr info extra))))))
@@ -83,7 +83,7 @@
 (define (disassemble-meta meta)
   (display "Meta info:\n\n")
   (for-each (lambda (data)
-	      (print-info (car data) (list->string (cdr data)) #f))
+	      (print-info (car data) (list->info (cdr data)) #f))
 	    meta)
   (newline))
 
@@ -109,7 +109,7 @@
 ;;;		      (if (pair? var) (car var) var))))
 	       (else #f)))))))
 
-(define (list->string list)
+(define (list->info list)
   (let ((str (object->string list)))
     (substring str 1 (1- (string-length str)))))
 

src/Makefile.am

@@ -7,8 +7,8 @@ lib_LTLIBRARIES = libguilevm.la
 libguilevm_la_SOURCES = envs.c instructions.c programs.c vm.c	\
 	envs.h instructions.h programs.h vm.h vm_engine.h vm_expand.h
 libguilevm_la_LDFLAGS = -version-info 0:0:0 -export-dynamic
-EXTRA_DIST = vm_engine.c vm_system.c vm_scheme.c vm_number.c vm_loader.c
+EXTRA_DIST = vm_engine.c vm_system.c vm_scheme.c vm_loader.c
-BUILT_SOURCES = vm_system.i vm_scheme.i vm_number.i vm_loader.i \
+BUILT_SOURCES = vm_system.i vm_scheme.i vm_loader.i \
 	envs.x instructions.x programs.x vm.x
 
 INCLUDES = $(GUILE_CFLAGS)

src/instructions.c

@@ -47,7 +47,6 @@ struct scm_instruction scm_instruction_table[] = {
 #include "vm_expand.h"
 #include "vm_system.i"
 #include "vm_scheme.i"
-#include "vm_number.i"
 #include "vm_loader.i"
 #undef VM_INSTRUCTION_TO_TABLE
   {scm_op_last}

src/instructions.h

@@ -50,7 +50,6 @@ enum scm_opcode {
 #include "vm_expand.h"
 #include "vm_system.i"
 #include "vm_scheme.i"
-#include "vm_number.i"
 #include "vm_loader.i"
 #undef VM_INSTRUCTION_TO_OPCODE
   scm_op_last

src/vm_engine.c

@@ -77,7 +77,6 @@ vm_engine (SCM vm, SCM program, SCM args)
 #include "vm_expand.h"
 #include "vm_system.i"
 #include "vm_scheme.i"
-#include "vm_number.i"
 #include "vm_loader.i"
 #undef VM_INSTRUCTION_TO_LABEL
   };
@@ -114,7 +113,6 @@ vm_engine (SCM vm, SCM program, SCM args)
 #include "vm_expand.h"
 #include "vm_system.c"
 #include "vm_scheme.c"
-#include "vm_number.c"
 #include "vm_loader.c"
 
 #ifndef HAVE_LABELS_AS_VALUES

src/vm_engine.h

@@ -249,7 +249,7 @@ do {						\
 #define ARGS3(a1,a2,a3)	SCM a1 = sp[2], a2 = sp[1], a3 = sp[0]; sp += 2;
 #define ARGSN(an)	int an = FETCH ();
 
-#define RETURN(x)	{ *sp = x; NEXT; }
+#define RETURN(x)	do { *sp = x; NEXT; } while (0)
 
 
 /*

src/vm_loader.c

@@ -58,11 +58,11 @@ VM_DEFINE_INSTRUCTION (load_integer, "load-integer", -1, 0, 1)
     SCM_MISC_ERROR ("load-integer: not implemented yet", SCM_EOL);
 }
 
-VM_DEFINE_INSTRUCTION (load_symbol, "load-symbol", -1, 0, 1)
+VM_DEFINE_INSTRUCTION (load_number, "load-number", -1, 0, 1)
 {
   size_t len;
   FETCH_LENGTH (len);
-  PUSH (scm_mem2symbol (ip, len));
+  PUSH (scm_istring2number (ip, len, 10));
   ip += len;
   NEXT;
 }
@@ -76,6 +76,15 @@ VM_DEFINE_INSTRUCTION (load_string, "load-string", -1, 0, 1)
   NEXT;
 }
 
+VM_DEFINE_INSTRUCTION (load_symbol, "load-symbol", -1, 0, 1)
+{
+  size_t len;
+  FETCH_LENGTH (len);
+  PUSH (scm_mem2symbol (ip, len));
+  ip += len;
+  NEXT;
+}
+
 VM_DEFINE_INSTRUCTION (load_keyword, "load-keyword", -1, 0, 1)
 {
   SCM sym;

src/vm_number.c

@@ -1,168 +0,0 @@
-/* Copyright (C) 2000 Free Software Foundation, Inc.
- *
- * 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, or (at your option)
- * any later version.
- * 
- * 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.
- * 
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING.  If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE.  If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way.  To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.  */
-
-/* This file is included in vm_engine.c */
-
-
-/*
- * Predicates
- */
-
-#undef PRED
-#define PRED(ctest,stest)			\
-{						\
-  ARGS1 (a1);					\
-  if (SCM_INUMP (a1))				\
-    RETURN (SCM_BOOL (ctest));			\
-  RETURN (stest (a1));				\
-}
-
-VM_DEFINE_FUNCTION (zero, "zero?", 1)
-{
-  PRED (SCM_INUM (a1) == 0, scm_zero_p);
-}
-
-
-/*
- * Relational tests
- */
-
-#undef REL
-#define REL(crel,srel)						\
-{								\
-  ARGS2 (a1, a2);						\
-  if (SCM_INUMP (a1) && SCM_INUMP (a2))				\
-    RETURN (SCM_BOOL (SCM_INUM (a1) crel SCM_INUM (a2)));	\
-  RETURN (srel (a1, a2));					\
-}
-
-VM_DEFINE_FUNCTION (ee, "ee?", 2)
-{
-  REL (==, scm_num_eq_p);
-}
-
-VM_DEFINE_FUNCTION (lt, "lt?", 2)
-{
-  REL (<, scm_less_p);
-}
-
-VM_DEFINE_FUNCTION (le, "le?", 2)
-{
-  REL (<=, scm_leq_p);
-}
-
-VM_DEFINE_FUNCTION (gt, "gt?", 2)
-{
-  REL (>, scm_gr_p);
-}
-
-VM_DEFINE_FUNCTION (ge, "ge?", 2)
-{
-  REL (>=, scm_geq_p);
-}
-
-
-/*
- * Functions
- */
-
-#undef FUNC1
-#define FUNC1(CEXP,SEXP)			\
-{						\
-  ARGS1 (a1);					\
-  if (SCM_INUMP (a1))				\
-    {						\
-      int n = CEXP;				\
-      if (SCM_FIXABLE (n))			\
-	RETURN (SCM_MAKINUM (n));		\
-    }						\
-  RETURN (SEXP);				\
-}
-
-#undef FUNC2
-#define FUNC2(CFUNC,SFUNC)				\
-{							\
-  ARGS2 (a1, a2);					\
-  if (SCM_INUMP (a1) && SCM_INUMP (a2))			\
-    {							\
-      int n = SCM_INUM (a1) CFUNC SCM_INUM (a2);	\
-      if (SCM_FIXABLE (n))				\
-	RETURN (SCM_MAKINUM (n));			\
-    }							\
-  RETURN (SFUNC (a1, a2));				\
-}
-
-VM_DEFINE_FUNCTION (neg, "neg", 1)
-{
-  FUNC1 (- SCM_INUM (a1), scm_difference (a1, SCM_UNDEFINED));
-}
-
-VM_DEFINE_FUNCTION (inc, "inc", 1)
-{
-  FUNC1 (SCM_INUM (a1) + 1, scm_sum (a1, SCM_MAKINUM (1)));
-}
-
-VM_DEFINE_FUNCTION (dec, "dec", 1)
-{
-  FUNC1 (SCM_INUM (a1) - 1, scm_difference (a1, SCM_MAKINUM (1)));
-}
-
-VM_DEFINE_FUNCTION (add, "add", 2)
-{
-  FUNC2 (+, scm_sum);
-}
-
-VM_DEFINE_FUNCTION (sub, "sub", 2)
-{
-  FUNC2 (-, scm_difference);
-}
-
-VM_DEFINE_FUNCTION (remainder, "remainder", 2)
-{
-  ARGS2 (a1, a2);
-  RETURN (scm_remainder (a1, a2));
-}
-
-/*
-  Local Variables:
-  c-file-style: "gnu"
-  End:
-*/

src/vm_scheme.c

@@ -41,106 +41,249 @@
 
 /* This file is included in vm_engine.c */
 
+
+/*
+ * Predicates
+ */
+
 VM_DEFINE_FUNCTION (not, "not", 1)
 {
-  ARGS1 (a1);
+  ARGS1 (x);
-  RETURN (SCM_BOOL (SCM_FALSEP (a1)));
+  RETURN (SCM_BOOL (SCM_FALSEP (x)));
 }
 
 VM_DEFINE_FUNCTION (not_not, "not-not", 1)
 {
-  ARGS1 (a1);
+  ARGS1 (x);
-  RETURN (SCM_BOOL (!SCM_FALSEP (a1)));
+  RETURN (SCM_BOOL (!SCM_FALSEP (x)));
 }
 
 VM_DEFINE_FUNCTION (eq, "eq?", 2)
 {
-  ARGS2 (a1, a2);
+  ARGS2 (x, y);
-  RETURN (SCM_BOOL (SCM_EQ_P (a1, a2)));
+  RETURN (SCM_BOOL (SCM_EQ_P (x, y)));
 }
 
 VM_DEFINE_FUNCTION (not_eq, "not-eq?", 2)
 {
-  ARGS2 (a1, a2);
+  ARGS2 (x, y);
-  RETURN (SCM_BOOL (!SCM_EQ_P (a1, a2)));
+  RETURN (SCM_BOOL (!SCM_EQ_P (x, y)));
 }
 
 VM_DEFINE_FUNCTION (nullp, "null?", 1)
 {
-  ARGS1 (a1);
+  ARGS1 (x);
-  RETURN (SCM_BOOL (SCM_NULLP (a1)));
+  RETURN (SCM_BOOL (SCM_NULLP (x)));
 }
 
 VM_DEFINE_FUNCTION (not_nullp, "not-null?", 1)
 {
-  ARGS1 (a1);
+  ARGS1 (x);
-  RETURN (SCM_BOOL (!SCM_NULLP (a1)));
+  RETURN (SCM_BOOL (!SCM_NULLP (x)));
+}
+
+VM_DEFINE_FUNCTION (eqv, "eqv?", 2)
+{
+  ARGS2 (x, y);
+  if (SCM_EQ_P (x, y))
+    RETURN (SCM_BOOL_T);
+  if (SCM_IMP (x) || SCM_IMP (y))
+    RETURN (SCM_BOOL_F);
+  SYNC_BEFORE_GC ();
+  RETURN (scm_eqv_p (x, y));
+}
+
+VM_DEFINE_FUNCTION (equal, "equal?", 2)
+{
+  ARGS2 (x, y);
+  if (SCM_EQ_P (x, y))
+    RETURN (SCM_BOOL_T);
+  if (SCM_IMP (x) || SCM_IMP (y))
+    RETURN (SCM_BOOL_F);
+  SYNC_BEFORE_GC ();
+  RETURN (scm_equal_p (x, y));
 }
 
 VM_DEFINE_FUNCTION (pairp, "pair?", 1)
 {
-  ARGS1 (a1);
+  ARGS1 (x);
-  RETURN (SCM_BOOL (SCM_CONSP (a1)));
+  RETURN (SCM_BOOL (SCM_CONSP (x)));
 }
 
 VM_DEFINE_FUNCTION (listp, "list?", 1)
 {
-  ARGS1 (a1);
+  ARGS1 (x);
-  RETURN (SCM_BOOL (scm_ilength (a1) >= 0));
+  RETURN (SCM_BOOL (scm_ilength (x) >= 0));
 }
 
+
+/*
+ * Basic data
+ */
+
 VM_DEFINE_FUNCTION (cons, "cons", 2)
 {
-  ARGS2 (a1, a2);
+  ARGS2 (x, y);
-  CONS (a1, a1, a2);
+  CONS (x, x, y);
-  RETURN (a1);
+  RETURN (x);
 }
 
 VM_DEFINE_FUNCTION (car, "car", 1)
 {
-  ARGS1 (a1);
+  ARGS1 (x);
-  SCM_VALIDATE_CONS (1, a1);
+  SCM_VALIDATE_CONS (1, x);
-  RETURN (SCM_CAR (a1));
+  RETURN (SCM_CAR (x));
 }
 
 VM_DEFINE_FUNCTION (cdr, "cdr", 1)
 {
-  ARGS1 (a1);
+  ARGS1 (x);
-  SCM_VALIDATE_CONS (1, a1);
+  SCM_VALIDATE_CONS (1, x);
-  RETURN (SCM_CDR (a1));
+  RETURN (SCM_CDR (x));
 }
 
 VM_DEFINE_FUNCTION (set_car, "set-car!", 2)
 {
-  ARGS2 (a1, a2);
+  ARGS2 (x, y);
-  SCM_VALIDATE_CONS (1, a1);
+  SCM_VALIDATE_CONS (1, x);
-  SCM_SETCAR (a1, a2);
+  SCM_SETCAR (x, y);
   RETURN (SCM_UNSPECIFIED);
 }
 
 VM_DEFINE_FUNCTION (set_cdr, "set-cdr!", 2)
 {
-  ARGS2 (a1, a2);
+  ARGS2 (x, y);
-  SCM_VALIDATE_CONS (1, a1);
+  SCM_VALIDATE_CONS (1, x);
-  SCM_SETCDR (a1, a2);
+  SCM_SETCDR (x, y);
   RETURN (SCM_UNSPECIFIED);
 }
 
 VM_DEFINE_FUNCTION (list, "list", -1)
 {
-  ARGSN (an);
+  ARGSN (n);
-  POP_LIST (an);
+  POP_LIST (n);
   NEXT;
 }
 
 VM_DEFINE_FUNCTION (vector, "vector", -1)
 {
-  ARGSN (an);
+  ARGSN (n);
-  POP_LIST (an);
+  POP_LIST (n);
+  SYNC_BEFORE_GC ();
   *sp = scm_vector (*sp);
   NEXT;
 }
 
+
+/*
+ * Numeric relational tests
+ */
+
+#undef REL
+#define REL(crel,srel)					\
+{							\
+  ARGS2 (x, y);						\
+  if (SCM_INUMP (x) && SCM_INUMP (y))			\
+    RETURN (SCM_BOOL (SCM_INUM (x) crel SCM_INUM (y)));	\
+  RETURN (srel (x, y));					\
+}
+
+VM_DEFINE_FUNCTION (ee, "ee?", 2)
+{
+  REL (==, scm_num_eq_p);
+}
+
+VM_DEFINE_FUNCTION (lt, "lt?", 2)
+{
+  REL (<, scm_less_p);
+}
+
+VM_DEFINE_FUNCTION (le, "le?", 2)
+{
+  REL (<=, scm_leq_p);
+}
+
+VM_DEFINE_FUNCTION (gt, "gt?", 2)
+{
+  REL (>, scm_gr_p);
+}
+
+VM_DEFINE_FUNCTION (ge, "ge?", 2)
+{
+  REL (>=, scm_geq_p);
+}
+
+
+/*
+ * Numeric functions
+ */
+
+#undef FUNC1
+#define FUNC1(CEXP,SEXP)			\
+{						\
+  ARGS1 (x);					\
+  if (SCM_INUMP (x))				\
+    {						\
+      int n = CEXP;				\
+      if (SCM_FIXABLE (n))			\
+	RETURN (SCM_MAKINUM (n));		\
+    }						\
+  RETURN (SEXP);				\
+}
+
+#undef FUNC2
+#define FUNC2(CFUNC,SFUNC)				\
+{							\
+  ARGS2 (x, y);					\
+  if (SCM_INUMP (x) && SCM_INUMP (y))			\
+    {							\
+      int n = SCM_INUM (x) CFUNC SCM_INUM (y);	\
+      if (SCM_FIXABLE (n))				\
+	RETURN (SCM_MAKINUM (n));			\
+    }							\
+  RETURN (SFUNC (x, y));				\
+}
+
+VM_DEFINE_FUNCTION (add, "add", 2)
+{
+  FUNC2 (+, scm_sum);
+}
+
+VM_DEFINE_FUNCTION (sub, "sub", 2)
+{
+  FUNC2 (-, scm_difference);
+}
+
+VM_DEFINE_FUNCTION (mul, "mul", 2)
+{
+  ARGS2 (x, y);
+  RETURN (scm_product (x, y));
+}
+
+VM_DEFINE_FUNCTION (div, "div", 2)
+{
+  ARGS2 (x, y);
+  RETURN (scm_divide (x, y));
+}
+
+VM_DEFINE_FUNCTION (quo, "quo", 2)
+{
+  ARGS2 (x, y);
+  RETURN (scm_quotient (x, y));
+}
+
+VM_DEFINE_FUNCTION (rem, "rem", 2)
+{
+  ARGS2 (x, y);
+  RETURN (scm_remainder (x, y));
+}
+
+VM_DEFINE_FUNCTION (mod, "mod", 2)
+{
+  ARGS2 (x, y);
+  RETURN (scm_modulo (x, y));
+}
+
 /*
   Local Variables:
   c-file-style: "gnu"