mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

*** empty log message ***

Browse source
This commit is contained in:
Keisuke Nishida 2001-04-06 09:11:32 +00:00
parent 499a4c07c7
commit a80be762c3
18 changed files with 267 additions and 375 deletions
Download patch file Download diff file Expand all files Collapse all files

25
module/language/gscheme/spec.scm
View file

@ -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)))
(case name
((quote) (cons '@quote args))
(let ((head (car x)) (rest (cdr x)))
(case head
((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))
(map translate (cdr args))))))
(car rest))
(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)))
(if (ghil-primitive? prim)
(cons prim (map translate args))
(cons (translate name) (map translate args))))))))
(let ((prim (and (symbol? head) (symbol-append '@ head))))
(if (and prim (ghil-primitive? prim))
(cons prim (map translate rest))
(cons (translate head) (map translate rest))))))))
;;;

1
module/language/r5rs/expand.scm
View file

@ -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")

1
module/language/r5rs/psyntax.boot
View file

@ -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"

2
module/language/r5rs/psyntax.scm
View file

File diff suppressed because one or more lines are too long

13
module/language/r5rs/psyntax.ss
View file

@ -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)))))))
(if (and (pair? x) (equal? (car x) noexpand))
(cadr x)
(chi-top x null-env user-top-wrap m esew user-ribcage))))))
(set! identifier?
(lambda (x)
@ -2927,7 +2926,7 @@
((_ ((out in) ...) e1 e2 ...)
(syntax (syntax-case (list in ...) ()
((out ...) (begin e1 e2 ...))))))))
(define-syntax syntax-rules
(lambda (x)
(syntax-case x ()

21
module/language/r5rs/spec.scm
View file

@ -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)))
(case name
((quote) (cons '@quote args))
(let ((head (car x)) (rest (cdr x)))
(case head
((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)
(map (lambda (b)
(cons (car b) (map translate (cdr b))))
(car args))
(map translate (cdr args))))
(cons* (symbol-append '@ head)
(map (lambda (b) (cons (car b) (map translate (cdr b))))
(car rest))
(map translate (cdr rest))))
((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))))))
;;;

137
module/system/il/macros.scm
View file

@ -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
@ -92,35 +79,26 @@
;;; 6.1 Equivalence predicates
(define (@eq? x y) `(@@ eq? ,x ,y))
(define (@eqv? x y) `(@@ eqv? ,x ,y))
(define (@equal? x y) `(@@ equal? ,x ,y))
(define (@eq? x y) `(@@ eq? ,x ,y))
(define (@eqv? x y) `(@@ eqv? ,x ,y))
(define (@equal? x y) `(@@ equal? ,x ,y))
;;; 6.2 Numbers
(define (@number? x) `(@@ number? ,x))
(define (@complex? x) `(@@ complex? ,x))
(define (@real? x) `(@@ real? ,x))
(define (@rational? x) `(@@ rational? ,x))
(define (@integer? x) `(@@ integer? ,x))
(define (@number? x) `((@ Core::number?) ,x))
(define (@complex? x) `((@ Core::complex?) ,x))
(define (@real? x) `((@ Core::real?) ,x))
(define (@rational? x) `((@ Core::rational?) ,x))
(define (@integer? x) `((@ Core::integer?) ,x))
(define (@exact? x) `(@@ exact? ,x))
(define (@inexact? x) `(@@ inexact? ,x))
(define (@exact? x) `((@ Core::exact?) ,x))
(define (@inexact? x) `((@ Core::inexact?) ,x))
(define (@= x y) `(@@ ee? ,x ,y))
(define (@< x y) `(@@ lt? ,x ,y))
(define (@> x y) `(@@ gt? ,x ,y))
(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 (@= x y) `(@@ ee? ,x ,y))
(define (@< x y) `(@@ lt? ,x ,y))
(define (@> x y) `(@@ gt? ,x ,y))
(define (@<= x y) `(@@ le? ,x ,y))
(define (@>= x y) `(@@ ge? ,x ,y))
(define @+
(match-lambda*
@ -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 @call-with-current-continuation)
;;; (define (@call/cc proc) `(@@ call/cc proc))
;;; 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)))

4
module/system/vm/assemble.scm
View file

@ -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)

28
module/system/vm/conv.scm
View file

@ -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) (list (C len)))
((< len (* 256 256))
(list (C 254) (C (quotient len 256)) (C (modulo len 256))))
((< len most-positive-fixnum)
(list (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)))))
(cond ((< len 254) (string (C len)))
((< len (* 256 256))
(string (C 254) (C (quotient len 256)) (C (modulo len 256))))
((< len most-positive-fixnum)
(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))))
(define (decode-length pop)
(let ((len (pop)))

6
module/system/vm/disasm.scm
View file

@ -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)))))

4
src/Makefile.am
View file

@ -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
BUILT_SOURCES = vm_system.i vm_scheme.i vm_number.i vm_loader.i \
EXTRA_DIST = vm_engine.c vm_system.c vm_scheme.c vm_loader.c
BUILT_SOURCES = vm_system.i vm_scheme.i vm_loader.i \
envs.x instructions.x programs.x vm.x
INCLUDES = $(GUILE_CFLAGS)

1
src/instructions.c
View file

@ -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}

1
src/instructions.h
View file

@ -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

2
src/vm_engine.c
View file

@ -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

2
src/vm_engine.h
View file

@ -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)
/*

13
src/vm_loader.c
View file

@ -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;

168
src/vm_number.c
View file

@ -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:
*/

213
src/vm_scheme.c
View file

@ -41,106 +41,249 @@
/* This file is included in vm_engine.c */
/*
* Predicates
*/
VM_DEFINE_FUNCTION (not, "not", 1)
{
ARGS1 (a1);
RETURN (SCM_BOOL (SCM_FALSEP (a1)));
ARGS1 (x);
RETURN (SCM_BOOL (SCM_FALSEP (x)));
}
VM_DEFINE_FUNCTION (not_not, "not-not", 1)
{
ARGS1 (a1);
RETURN (SCM_BOOL (!SCM_FALSEP (a1)));
ARGS1 (x);
RETURN (SCM_BOOL (!SCM_FALSEP (x)));
}
VM_DEFINE_FUNCTION (eq, "eq?", 2)
{
ARGS2 (a1, a2);
RETURN (SCM_BOOL (SCM_EQ_P (a1, a2)));
ARGS2 (x, y);
RETURN (SCM_BOOL (SCM_EQ_P (x, y)));
}
VM_DEFINE_FUNCTION (not_eq, "not-eq?", 2)
{
ARGS2 (a1, a2);
RETURN (SCM_BOOL (!SCM_EQ_P (a1, a2)));
ARGS2 (x, y);
RETURN (SCM_BOOL (!SCM_EQ_P (x, y)));
}
VM_DEFINE_FUNCTION (nullp, "null?", 1)
{
ARGS1 (a1);
RETURN (SCM_BOOL (SCM_NULLP (a1)));
ARGS1 (x);
RETURN (SCM_BOOL (SCM_NULLP (x)));
}
VM_DEFINE_FUNCTION (not_nullp, "not-null?", 1)
{
ARGS1 (a1);
RETURN (SCM_BOOL (!SCM_NULLP (a1)));
ARGS1 (x);
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);
RETURN (SCM_BOOL (SCM_CONSP (a1)));
ARGS1 (x);
RETURN (SCM_BOOL (SCM_CONSP (x)));
}
VM_DEFINE_FUNCTION (listp, "list?", 1)
{
ARGS1 (a1);
RETURN (SCM_BOOL (scm_ilength (a1) >= 0));
ARGS1 (x);
RETURN (SCM_BOOL (scm_ilength (x) >= 0));
}
/*
* Basic data
*/
VM_DEFINE_FUNCTION (cons, "cons", 2)
{
ARGS2 (a1, a2);
CONS (a1, a1, a2);
RETURN (a1);
ARGS2 (x, y);
CONS (x, x, y);
RETURN (x);
}
VM_DEFINE_FUNCTION (car, "car", 1)
{
ARGS1 (a1);
SCM_VALIDATE_CONS (1, a1);
RETURN (SCM_CAR (a1));
ARGS1 (x);
SCM_VALIDATE_CONS (1, x);
RETURN (SCM_CAR (x));
}
VM_DEFINE_FUNCTION (cdr, "cdr", 1)
{
ARGS1 (a1);
SCM_VALIDATE_CONS (1, a1);
RETURN (SCM_CDR (a1));
ARGS1 (x);
SCM_VALIDATE_CONS (1, x);
RETURN (SCM_CDR (x));
}
VM_DEFINE_FUNCTION (set_car, "set-car!", 2)
{
ARGS2 (a1, a2);
SCM_VALIDATE_CONS (1, a1);
SCM_SETCAR (a1, a2);
ARGS2 (x, y);
SCM_VALIDATE_CONS (1, x);
SCM_SETCAR (x, y);
RETURN (SCM_UNSPECIFIED);
}
VM_DEFINE_FUNCTION (set_cdr, "set-cdr!", 2)
{
ARGS2 (a1, a2);
SCM_VALIDATE_CONS (1, a1);
SCM_SETCDR (a1, a2);
ARGS2 (x, y);
SCM_VALIDATE_CONS (1, x);
SCM_SETCDR (x, y);
RETURN (SCM_UNSPECIFIED);
}
VM_DEFINE_FUNCTION (list, "list", -1)
{
ARGSN (an);
POP_LIST (an);
ARGSN (n);
POP_LIST (n);
NEXT;
}
VM_DEFINE_FUNCTION (vector, "vector", -1)
{
ARGSN (an);
POP_LIST (an);
ARGSN (n);
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"