Commit 4fbad503 authored by Mark Probst's avatar Mark Probst

Add guile plug-in.

parent e36eb87f
1998-11-11 Mark Probst <schani@obiwan.unix.cslab.tuwien.ac.at>
* plugins/guile: Added guile plug-in.
1998-11-11 Michael Meeks <michael@imaginator.com>
* plugins/excel/ms-biff.h, plugins/excel/ms-excel.c: Removed fatal
......
1998-11-11 Mark Probst <schani@obiwan.unix.cslab.tuwien.ac.at>
* plugins/guile: Added guile plug-in.
1998-11-11 Michael Meeks <michael@imaginator.com>
* plugins/excel/ms-biff.h, plugins/excel/ms-excel.c: Removed fatal
......
1998-11-11 Mark Probst <schani@obiwan.unix.cslab.tuwien.ac.at>
* plugins/guile: Added guile plug-in.
1998-11-11 Michael Meeks <michael@imaginator.com>
* plugins/excel/ms-biff.h, plugins/excel/ms-excel.c: Removed fatal
......
1998-11-11 Mark Probst <schani@obiwan.unix.cslab.tuwien.ac.at>
* plugins/guile: Added guile plug-in.
1998-11-11 Michael Meeks <michael@imaginator.com>
* plugins/excel/ms-biff.h, plugins/excel/ms-excel.c: Removed fatal
......
......@@ -8,3 +8,4 @@
#undef HAVE_STPCPY
#undef HAVE_ORBIT
#undef HAVE_GTK_SELECTION_ADD_TARGET
#undef HAVE_GUILE
......@@ -17,6 +17,7 @@ AM_PROG_LIBTOOL
GNOME_COMPILE_WARNINGS
GNOME_X_CHECKS
GNOME_XML_CHECK
GNOME_CHECK_GUILE
dnl
dnl Check for ORBit
......@@ -114,6 +115,7 @@ plugins/python/Makefile
plugins/perl/Makefile
plugins/perl/ext/Makefile.PL
plugins/stat/Makefile
plugins/guile/Makefile
intl/Makefile
po/Makefile.in
macros/Makefile
......
......@@ -11,4 +11,10 @@ else
PERL =
endif
SUBDIRS = sample $(PYTHON) $(PERL) stat excel
if GUILE
GUILE_DIR = guile
else
GUILE_DIR =
endif
SUBDIRS = sample $(PYTHON) $(PERL) stat excel $(GUILE_DIR)
#
# Makefile for the Guile Gnumeric plugin.
#
# Where can we find the Gnumeric include files.
#
GNUMERIC_SRC_DIR = $(srcdir)/../../src
#
# Where to install the plugin
#
plugindir = $(libdir)/gnumeric/plugins
# CFLAGS += -g -Wall \
# -Wshadow -Wpointer-arith \
# -Wmissing-prototypes -Wmissing-declarations
plugin_LTLIBRARIES = libgnumguile.la
libgnumguile_la_SOURCES = plugin.c
INCLUDES = \
-I$(GNUMERIC_SRC_DIR) \
-DGNOMELOCALEDIR=\""$(datadir)/locale"\" \
-I$(includedir) \
$(GUILE_INCS) \
$(GNOME_INCLUDEDIR)
#libguile_la_LDFLAGS = $(PYTHON_LIB_LOC)
libgnumguile_la_LIBADD = $(GUILE_LIBS)
Guilescriptsdir = $(datadir)/gnumeric/guile
Guilescripts_DATA = gnumeric_startup.scm
EXTRA_DIST = gnumeric_startup.scm
; -*- scheme -*-
;
; Gnumeric Guile plug-in system startup file
;
; Mark Probst (schani@unix.cslab.tuwien.ac.at)
;
(display "Guile plug-in initializing\n")
; cell-refs
(define (make-cell-ref col row)
(if (and (number? col) (number? row))
(cons 'cell-ref (cons col row))
'()))
(define (cell-ref? ob)
(and (pair? ob) (eq? (car ob) 'cell-ref)))
(define cell-ref-col cadr)
(define cell-ref-row cddr)
; vars
(define (make-var cell-ref)
(cons 'var cell-ref))
(define (var? ob)
(and (pair? ob) (eq? (car ob) 'var)))
(define var-cell-ref cdr)
; operators
(define binary-operator? '())
(define binary-operator-name '())
(define binary-operator-function '())
(let ((binary-op-names
(list (cons '= "=")
(cons '> ">")
(cons '< "<")
(cons '>= ">=")
(cons '<= "<=")
(cons '<> "<>")
(cons '+ "+")
(cons '- "-")
(cons '* "*")
(cons '/ "/")
(cons 'expt "^")
(cons 'string-append "&")))
(binary-op-funcs
(list (cons '= =)
(cons '> >)
(cons '< <)
(cons '>= >=)
(cons '<= <=)
(cons '<> (lambda (n1 n2) (not (= n1 n2))))
(cons '+ +)
(cons '- -)
(cons '* *)
(cons '/ /)
(cons 'expt expt)
(cons 'string-append string-append))))
(set! binary-operator?
(lambda (op)
(if (assq op binary-op-names) #t #f)))
(set! binary-operator-name
(lambda (op)
(cdr (assq op binary-op-names))))
(set! binary-operator-function
(lambda (op)
(cdr (assq op binary-op-funcs)))))
; exprs
;; this should really be coded in C
(define (unparse-expr expr)
(define (unparse-subexpr expr)
(cond ((number? expr)
(number->string expr))
((string? expr)
(string-append "\"" expr "\"")) ; FIXME: should also quote "'s inside
((var? expr)
(let ((cell-ref (var-cell-ref expr)))
(string-append
(string (integer->char (+ (char->integer #\A) (cell-ref-col cell-ref)))) ; FIXME: this only works if col < 26
(number->string (+ (cell-ref-row cell-ref) 1)))))
((list? expr)
(let ((op (car expr)))
(cond ((binary-operator? op)
(string-append "("
(unparse-subexpr (cadr expr))
(binary-operator-name op)
(unparse-subexpr (caddr expr))
")"))
((eq? op 'neg)
(string-append "-(" (unparse-subexpr (cadr expr)) ")"))
((eq? op 'funcall)
(string-append (cadr expr) "()")) ; FIXME: should unparse args
(else
"ERROR"))))
(else
"ERROR")))
(string-append "=" (unparse-subexpr expr)))
;; this should also be coded in C
(define (eval-expr expr)
(define (eval-expr-list expr-list)
(if (null? expr-list)
'()
(cons (eval-expr (car expr-list)) (eval-expr-list (cdr expr-list)))))
(cond ((number? expr) expr)
((string? expr) expr)
((var? expr) (cell-value (var-cell-ref expr)))
((list? expr)
(let ((op (car expr)))
(cond ((binary-operator? op)
((binary-operator-function op) (eval-expr (cadr expr)) (eval-expr (caddr expr))))
((eq? op 'neg)
(- (eval-expr (cadr expr))))
((eq? op 'funcall)
(gnumeric-funcall (cadr expr) (eval-expr-list (caddr expr))))
(else
"ERROR"))))
(else
"ERROR")))
; a few simple functions
(define (sign num)
(cond ((negative? num) -1)
((zero? num) 0)
(else 1)))
(register-function
"sign" "f"
"@FUNCTION=SIGN
@SYNTAX=SIGN(number)
@DESCRIPTION=Returns -1 if NUMBER is less than 0, 1 if NUMBER
is greater than 0 and 0 if NUMBER is equal 0."
sign)
(register-function
"lcm" "ff"
"@FUNCTION=LCM
@SYNTAX=LCM(n1,n2)
@DESCRIPTION=Returns the least common multiplier of N1 and N2."
lcm)
(register-function
"gcd" "ff"
"@FUNCTION=GCD
@SYNTAX=GCD(n1,n2)
@DESCRIPTION=Returns the greatest common divisor of N1 and N2."
gcd)
; symbolic differentiation with immediate evaluation
;; in case of a funcall this should do numeric differentiation
(define (differentiate expr var)
(cond ((number? expr) 0)
((var? expr)
(let ((cell-ref (var-cell-ref expr)))
(if (equal? var cell-ref)
1
(differentiate (cell-expr cell-ref) var))))
((list? expr)
(let ((op (car expr)))
(cond ((binary-operator? op)
(let ((left-arg (cadr expr))
(right-arg (caddr expr)))
(cond ((eq? op '+)
(+ (differentiate left-arg var) (differentiate right-arg var)))
((eq? op '-)
(- (differentiate left-arg var) (differentiate right-arg var)))
((eq? op '*)
(+ (* (eval-expr left-arg) (differentiate right-arg var))
(* (eval-expr right-arg) (differentiate left-arg var))))
((eq? op '/)
(let ((v (eval-expr right-arg)))
(/ (- (* (differentiate left-arg var) v)
(* (differentiate right-arg var) (eval-expr left-arg)))
(* v v))))
((eq? op 'expt)
(let ((u (eval-expr left-arg))
(v (eval-expr right-arg))
(du (differentiate left-arg var))
(dv (differentiate right-arg var)))
(+ (* (expt u (- v 1)) v du) (* (expt u v) (log u) dv))))
(else
"ERROR"))))
((eq? op 'neg)
(- (differentiate (cadr expr) var)))
(else
"ERROR"))))
(else
"ERROR")))
; a little expression simplifier and constant folder
(define (simplify-expr expr)
(define (constant? expr)
(or (number? expr) (string? expr)))
(cond ((or (number? expr) (string? expr) (var? expr))
expr)
((list? expr)
(let ((op (car expr)))
(cond ((binary-operator? op)
(let* ((left-arg (simplify-expr (cadr expr)))
(right-arg (simplify-expr (caddr expr)))
(new-expr (list op left-arg right-arg)))
(cond ((and (constant? left-arg) (constant? right-arg))
(eval-expr new-expr))
((and (eq? op '+) (number? left-arg) (zero? left-arg))
right-arg)
((and (or (eq? op '+) (eq? op '-)) (number? right-arg) (zero? right-arg))
left-arg)
((and (eq? op '*) (number? left-arg) (= left-arg 1))
right-arg)
((and (or (eq? op '*) (eq? op '/)) (number? right-arg) (= right-arg 1))
left-arg)
((and (eq? op 'expt) (number? left-arg) (or (zero? left-arg) (= left-arg 1)))
left-arg)
((and (eq? op 'expt) (number? right-arg) (= right-arg 1))
left-arg)
(else
new-expr))))
((eq? op 'neg)
(let* ((arg (simplify-expr (cadr expr)))
(new-expr (list op arg)))
(if (constant? arg)
(eval-expr new-expr)
new-expr)))
(else
expr)))) ; should also handle functions without side effects
(else
expr)))
; load user init-file if present
(let ((home-gnumericrc (string-append (getenv "HOME") "/.gnumeric.scm")))
(if (access? home-gnumericrc R_OK)
(load home-gnumericrc)))
(display "Guile plug-in initialization complete\n")
/* -*- mode: c; c-basic-offset: 8 -*- */
#include <assert.h>
#include <stdio.h>
#include <libguile.h>
#include <glib.h>
#include <gnome.h>
#include "../../src/gnumeric.h"
#include "../../src/symbol.h"
#include "../../src/plugin.h"
#include "../../src/expr.h"
#include "../../src/func.h"
static int
scm_num2int (SCM num)
{
return (int)scm_num2long(num, (char*)SCM_ARG1, "scm_num2int"); /* may I use scm_num2long? */
}
static SCM
scm_symbolfrom0str (char *name)
{
return SCM_CAR(scm_intern0(name));
}
static SCM
list_to_scm (GList *list, CellRef eval_cell)
{
/* FIXME: implement this */
return SCM_EOL;
}
static SCM
cell_ref_to_scm (CellRef cell, CellRef eval_cell)
{
int col = cell.col_relative ? cell.col + eval_cell.col : cell.col,
row = cell.row_relative ? cell.row + eval_cell.row : cell.row;
return scm_cons(scm_symbolfrom0str("cell-ref"),
scm_cons(scm_long2num(col), scm_long2num(row)));
/* FIXME: we need the relative-flags also */
}
static CellRef
scm_to_cell_ref (SCM scm)
{
CellRef cell = { 0, 0, 0, 0 };
if (SCM_NIMP(scm) && SCM_CONSP(scm)
&& SCM_NFALSEP(scm_eq_p(SCM_CAR(scm), scm_symbolfrom0str("cell-ref")))
&& SCM_NIMP(SCM_CDR(scm)) && SCM_CONSP(SCM_CDR(scm))
&& SCM_NFALSEP(scm_number_p(SCM_CADR(scm))) && SCM_NFALSEP(scm_number_p(SCM_CDDR(scm))))
{
cell.col = (int)scm_num2int(SCM_CADR(scm));
cell.row = (int)scm_num2int(SCM_CDDR(scm));
}
else
; /* FIXME: should report error */
return cell;
}
static SCM
value_to_scm (Value *val, CellRef cell_ref)
{
if (val == NULL)
return SCM_EOL;
switch (val->type)
{
case VALUE_STRING :
return scm_makfrom0str(val->v.str->str);
case VALUE_INTEGER :
return scm_long2num(val->v.v_int);
case VALUE_FLOAT :
return scm_dbl2big(val->v.v_float);
case VALUE_CELLRANGE :
return scm_cons(scm_symbolfrom0str("cell-range"),
scm_cons(cell_ref_to_scm(val->v.cell_range.cell_a, cell_ref),
cell_ref_to_scm(val->v.cell_range.cell_b, cell_ref)));
case VALUE_ARRAY :
return SCM_UNSPECIFIED;
}
return SCM_UNSPECIFIED;
}
static Value*
scm_to_value (SCM scm)
{
if (SCM_NIMP(scm) && SCM_STRINGP(scm))
{
Value *val = g_new(Value, 1);
val->type = VALUE_STRING;
val->v.str = string_get(SCM_CHARS(scm)); /* assuming (wrongly?) that scm strings are zero-terminated */
return val;
}
else if (SCM_NFALSEP(scm_number_p(scm)))
{
if (scm_integer_p(scm))
return value_int((int)scm_num2int(scm));
else
return value_float((float)scm_num2dbl(scm, 0));
}
else if (SCM_NIMP(scm) && SCM_CONSP(scm))
{
if (scm_eq_p(SCM_CAR(scm), scm_symbolfrom0str("cell-range"))
&& SCM_NIMP(SCM_CDR(scm)) && SCM_CONSP(SCM_CDR(scm)))
{
Value *val = g_new(Value, 1);
val->type = VALUE_CELLRANGE;
val->v.cell_range.cell_a = scm_to_cell_ref(SCM_CADR(scm));
val->v.cell_range.cell_b = scm_to_cell_ref(SCM_CDDR(scm));
return val;
}
}
return NULL; /* maybe we should return something more meaningful!? */
}
static SCM
expr_to_scm (ExprTree *expr, CellRef cell_ref)
{
switch (expr->oper)
{
case OPER_EQUAL :
return SCM_LIST3(scm_symbolfrom0str("="),
expr_to_scm(expr->u.binary.value_a, cell_ref),
expr_to_scm(expr->u.binary.value_b, cell_ref));
case OPER_GT :
return SCM_LIST3(scm_symbolfrom0str(">"),
expr_to_scm(expr->u.binary.value_a, cell_ref),
expr_to_scm(expr->u.binary.value_b, cell_ref));
case OPER_LT :
return SCM_LIST3(scm_symbolfrom0str("<"),
expr_to_scm(expr->u.binary.value_a, cell_ref),
expr_to_scm(expr->u.binary.value_b, cell_ref));
case OPER_GTE :
return SCM_LIST3(scm_symbolfrom0str(">="),
expr_to_scm(expr->u.binary.value_a, cell_ref),
expr_to_scm(expr->u.binary.value_b, cell_ref));
case OPER_LTE :
return SCM_LIST3(scm_symbolfrom0str("<="),
expr_to_scm(expr->u.binary.value_a, cell_ref),
expr_to_scm(expr->u.binary.value_b, cell_ref));
case OPER_NOT_EQUAL :
return SCM_LIST3(scm_symbolfrom0str("<>"),
expr_to_scm(expr->u.binary.value_a, cell_ref),
expr_to_scm(expr->u.binary.value_b, cell_ref));
case OPER_ADD :
return SCM_LIST3(scm_symbolfrom0str("+"),
expr_to_scm(expr->u.binary.value_a, cell_ref),
expr_to_scm(expr->u.binary.value_b, cell_ref));
case OPER_SUB :
return SCM_LIST3(scm_symbolfrom0str("-"),
expr_to_scm(expr->u.binary.value_a, cell_ref),
expr_to_scm(expr->u.binary.value_b, cell_ref));
case OPER_NEG :
return SCM_LIST2(scm_symbolfrom0str("neg"),
expr_to_scm(expr->u.value, cell_ref));
case OPER_MULT :
return SCM_LIST3(scm_symbolfrom0str("*"),
expr_to_scm(expr->u.binary.value_a, cell_ref),
expr_to_scm(expr->u.binary.value_b, cell_ref));
case OPER_DIV :
return SCM_LIST3(scm_symbolfrom0str("/"),
expr_to_scm(expr->u.binary.value_a, cell_ref),
expr_to_scm(expr->u.binary.value_b, cell_ref));
case OPER_EXP :
return SCM_LIST3(scm_symbolfrom0str("expt"),
expr_to_scm(expr->u.binary.value_a, cell_ref),
expr_to_scm(expr->u.binary.value_b, cell_ref));
case OPER_CONCAT :
return SCM_LIST3(scm_symbolfrom0str("string-append"),
expr_to_scm(expr->u.binary.value_a, cell_ref),
expr_to_scm(expr->u.binary.value_b, cell_ref));
case OPER_FUNCALL :
return SCM_LIST3(scm_symbolfrom0str("funcall"),
scm_makfrom0str(expr->u.function.symbol->str),
list_to_scm(expr->u.function.arg_list, cell_ref));
case OPER_CONSTANT :
return value_to_scm(expr->u.constant, cell_ref);
case OPER_VAR :
return scm_cons(scm_symbolfrom0str("var"),
cell_ref_to_scm(expr->u.constant->v.cell, cell_ref));
}
return SCM_UNSPECIFIED;
}
static Value*
func_scm_eval (FunctionDefinition *fn, Value *argv[], char **error_string)
{
SCM result;
if (argv[0]->type != VALUE_STRING)
{
*error_string = "Argument must be a Guile expression";
return NULL;
}
result = scm_eval_0str(argv[0]->v.str->str);
return scm_to_value(result);
}
static Value*
func_scm_apply (void *tsheet, GList *expr_node_list, int eval_col, int eval_row, char **error_string)
{
int i;
Value *value;
char *symbol;
SCM args = SCM_EOL,
function,
result;
if (g_list_length(expr_node_list) < 1)
{
*error_string = "Invalid number of arguments";
return NULL;
}
value = eval_expr(tsheet, (ExprTree*)expr_node_list->data, eval_col, eval_row, error_string);
if (value == NULL)
{
*error_string = "First argument to SCM must be a Guile expression";
return NULL;
}
symbol = value_string(value);
if (symbol == NULL)
{
*error_string = "First argument to SCM must be a Guile expression";
return NULL;
}
function = scm_eval_0str(symbol);
if (SCM_UNBNDP(function))
{
*error_string = "Undefined scheme function";
return NULL;
}
value_release(value);
for (i = g_list_length(expr_node_list) - 1; i >= 1; --i)
{
CellRef eval_cell = { eval_col, eval_row, 0, 0 };
value = eval_expr(tsheet, (ExprTree*)g_list_nth(expr_node_list, i)->data, eval_col, eval_row, error_string);
if (value == NULL)
{
*error_string = "Could not evaluate argument";
return NULL;
}
args = scm_cons(value_to_scm(value, eval_cell), args);
value_release(value);
}
result = scm_apply(function, args, SCM_EOL);
return scm_to_value(result);
}
static SCM
scm_cell_value (SCM scm)
{
CellRef cell_ref = scm_to_cell_ref(scm);
Cell *cell = sheet_cell_get(workbook_get_current_sheet(current_workbook), cell_ref.col, cell_ref.row);
if (cell == NULL)
return SCM_EOL;
assert(cell->value != NULL);