Commit 94621d54 authored by Erick Gallesio's avatar Erick Gallesio

Better export macros

parent a160d72c
......@@ -2,7 +2,7 @@
#
# Author: Erick Gallesio [eg@unice.fr]
# Creation date: 11-Apr-2000 10:30 (eg)
# Last file update: 26-Apr-2007 16:47 (eg)
# Last file update: 26-Apr-2007 18:44 (eg)
SUBDIRS = Match.d SILex.d Lalr.d ScmPkg.d @LURCDIR@
......@@ -146,7 +146,7 @@ boot: ../src/boot.img
cp ./instr3 ../src/vm-instr.h; \
echo "*** Create new boot.c"; \
(export STKLOS_BUILDING=1; \
./src/stklos -q -c -b ../src/boot.img \
../src/stklos -q -c -b ../src/boot.img \
-f make-C-boot.stk -- boot.img3 ../src/boot.c); \
echo "*** Recompile STklos"; \
(cd ../src; make stklos); \
......
......@@ -18,7 +18,7 @@
#
# Author: Erick Gallesio [eg@unice.fr]
# Creation date: 11-Apr-2000 10:30 (eg)
# Last file update: 26-Apr-2007 16:47 (eg)
# Last file update: 26-Apr-2007 18:44 (eg)
VPATH = @srcdir@
pkgdatadir = $(datadir)/@PACKAGE@
......@@ -661,7 +661,7 @@ boot: ../src/boot.img
cp ./instr3 ../src/vm-instr.h; \
echo "*** Create new boot.c"; \
(export STKLOS_BUILDING=1; \
./src/stklos -q -c -b ../src/boot.img \
../src/stklos -q -c -b ../src/boot.img \
-f make-C-boot.stk -- boot.img3 ../src/boot.c); \
echo "*** Recompile STklos"; \
(cd ../src; make stklos); \
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 26-Feb-2000 10:47 (eg)
;;;; Last file update: 26-Apr-2007 12:15 (eg)
;;;; Last file update: 4-May-2007 15:10 (eg)
;;;;
(define-module STKLOS-COMPILER
......@@ -305,7 +305,7 @@ doc>
(compile val env args #f)
(compile-access var env args #f))
(compiler-error 'set! args "~S is a bad symbol" var))))
(compiler-error 'set! args "bad assignment syntax in ~S" args))))
(compiler-error 'set! (cdr args) "bad assignment syntax in ~S" args))))
;;;;
;;;; IF
......@@ -365,17 +365,24 @@ doc>
;;;;
;;;; WHEN/UNLESS
;;;;
(define (compile-when args env tail?)
(let ((len (length (cdr args))))
(define-macro (when . args)
(let ((len (length args)))
(if (> len 1)
(compile `(if ,(cadr args) (begin ,@(cddr args))) env args tail?)
(compiler-error 'when args "bad syntax in ~S" args))))
`(if ,(car args) (begin ,@(cdr args)))
(compiler-error 'when args "bad syntax in ~S" `(when ,@args)))))
(define (compile-unless args env tail?)
(let ((len (length (cdr args))))
(define-macro (unless . args)
(let ((len (length args)))
(if (> len 1)
(compile `(if (not ,(cadr args)) (begin ,@(cddr args))) env args tail?)
(compiler-error 'unless args "bad syntax in ~S" args))))
`(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))
#|
......@@ -1550,7 +1557,6 @@ doc>
(compile-constant e env tail?))
(begin
(case (car e)
((quote) (compile-quote e env tail?))
((if) (compile-if e env tail?))
((define) (compile-define e env tail?))
((begin) (compile-begin e env tail?))
......@@ -1558,17 +1564,16 @@ doc>
((let) (compile-let e env tail?))
((let*) (compile-let* e env tail?))
((letrec) (compile-letrec e env tail?))
((set!) (compile-set! 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?))
((when) (compile-when e env tail?))
((unless) (compile-unless e env tail?))
((quote) (compile-quote e env tail?))
((quasiquote) (compile-quasiquote e env tail?))
((with-handler) (compile-with-handler e env tail?))
((define-macro) (compile-define-macro e env tail?))
((%%set!) (compile-set! e env tail?))
;; Special calls
((%%require) (compile-require e env tail?))
......
......@@ -23,7 +23,7 @@
;;;; Copyright (c) 1991, Marc Feeley
;;;;
;;;; Creation date: 10-May-2002 16:22 (eg)
;;;; Last file update: 20-Apr-2007 17:31 (eg)
;;;; Last file update: 30-Apr-2007 00:28 (eg)
;;;;
#|
......@@ -136,7 +136,8 @@ doc>
((eof-object? obj) (out "#eof" col))
;; STk types
((keyword? obj) (out (string-append ":" (keyword->string obj)) col))
((hash-table? obj) (out "#[hash-table]"))
((eq? obj (void)) (out "#void" col))
((hash-table? obj) (out "#[hash-table]" col))
(else (out "#[unknown]" col))))
(define (pp obj col)
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 15-Mar-2001 22:49 (eg)
;;;; Last file update: 26-Apr-2007 17:48 (eg)
;;;; Last file update: 5-May-2007 09:41 (eg)
;;;;
......@@ -42,6 +42,11 @@
(define (filter-map func . args)
(filter (lambda (x) x)
(apply map func args)))
#| example
(filter-map (lambda (x) (and (number? x) (+ x 1)))
'(1 2 foo "bar" 7))
|#
(define (append-map proc . args)
(apply append (apply map proc args)))
......@@ -50,11 +55,13 @@
(apply append! (apply map proc args)))
#| example
(filter-map (lambda (x) (and (number? x) (+ x 1)))
'(1 2 foo "bar" 7))
|#
(define (symbol-append . args)
(let loop ((args args)
(res ""))
(if (null? args)
(string->symbol res)
(loop (cdr args)
(string-append res (format "~a" (car args)))))))
;; ----------------------------------------------------------------------
;; management of globals ...
......@@ -135,14 +142,18 @@
(set! *expander-published* '()))
(define (expander-published-sources)
(let Loop ((lst *expander-published*)
(res '()))
(if (null? lst)
(reverse! res)
(let ((mac (assoc (car lst) *expander-list-src*)))
(if mac
(Loop (cdr lst) (cons mac res))
(error "cannot find source of syntax named ~S" (car lst)))))))
(let ((warning (in-module |STKLOS-COMPILER| compiler-warning)))
(let Loop ((lst *expander-published*)
(res '()))
(if (null? lst)
(reverse! res)
(let ((mac (assoc (car lst) *expander-list-src*)))
(if mac
(Loop (cdr lst) (cons mac res))
(begin
(warning (void) 'export-syntax
"cannot find source of syntax named ~S" (car lst))
(Loop (cdr lst) res))))))))
(define (expander-published-add! name)
(unless (memq name *expander-published*)
......
;;;;
;;;; srfi-11.stk -- LET-VALUES and LET*-VALUES
;;;;
;;;; Copyright 2002 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;; Copyright 2002-2007 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 28-May-2002 09:47 (eg)
;;;; Last file update: 5-Jun-2002 16:09 (eg)
;;;; Last file update: 4-May-2007 19:41 (eg)
;;;;
......@@ -60,6 +60,8 @@
(let-values (?binding0)
(let*-values (?binding1 ...) ?body0 ?body1 ...)))))
(export-syntax let-values let*-values)
(provide "srfi-11")
#|
......
......@@ -5,7 +5,7 @@
;; that can be found at "http://pobox.com/~oleg/ftp/Scheme/vland.scm".
;;
;; Creation date: 30-Aug-1999 14:43 (eg)
;; Last file update: 9-Apr-2001 23:12 (eg)
;; Last file update: 4-May-2007 19:41 (eg)
;;
;;=============================================================================
......@@ -180,4 +180,5 @@
(andjoin! `(begin ,@body)))
result))
(export-syntax and-let*)
(provide "srfi-2")
;;;;
;;;; srfi-26.stk -- SRFI-26 implementation
;;;;
;;;; Copyright 2003 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
;;;; Copyright 2003-2007 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 19-Dec-2003 12:57 (eg)
;;;; Last file update: 19-Dec-2003 22:32 (eg)
;;;; Last file update: 4-May-2007 19:49 (eg)
;;;;
;; ======================================================================
......@@ -92,5 +92,5 @@
;;
(aux slots-or-exprs '() '() '()))
(export-syntax cute cut)
(provide "srfi-26")
;;;;
;;;; srfi-31.stk -- A special form rec for recursive evaluation
;;;;
;;;; Copyright 2002 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;; Copyright 2002-2007 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 3-Dec-2002 21:31 (eg)
;;;; Last file update: 3-Dec-2002 21:33 (eg)
;;;; Last file update: 4-May-2007 19:43 (eg)
;;;;
;;; The implementation given in the SRFI-31 document
......@@ -43,4 +43,5 @@
(bindings (cdr name)))
`(letrec ((,name (lambda ,bindings ,@body))) ,name))))
(export-syntax rec)
(provide "srfi-31")
\ No newline at end of file
;;;;
;;;; srfi-34.stk -- SRFI-34 support
;;;;
;;;; Copyright © 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
;;;; Copyright © 2004-2007 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 27-May-2004 22:00 (eg)
;;;; Last file update: 28-May-2004 11:58 (eg)
;;;; Last file update: 4-May-2007 19:43 (eg)
;;;;
......@@ -113,4 +113,6 @@ doc>
(else (raise ,var)))))))
`(with-handler ,hdlr ,@body)))
(export-syntax with-exception-handler guard)
(provide "srfi-34")
;;;;
;;;; srfi-35.stk -- Implementation of SRFI-35 (Conditions)
;;;;
;;;; Copyright © 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
;;;; Copyright © 2004-2007 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 25-May-2004 10:13 (eg)
;;;; Last file update: 3-Jun-2004 13:23 (eg)
;;;; Last file update: 4-May-2007 19:45 (eg)
;;;;
;; ----------------------------------------------------------------------
......@@ -86,6 +86,7 @@
(location error-location)
(message error-message))
(export-syntax define-condition-type condition)
(provide "srfi-35")
......
;;;; srfi-7.stk -- SRFI-7 (PROGRAM)
;;;;
;;;; Copyright © 1999-2002 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;; Copyright © 1999-2007 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;; 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
......@@ -22,7 +22,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 31-Aug-1999 16:10 (eg)
;;;; Last file update: 5-Jun-2002 11:15 (eg)
;;;; Last file update: 4-May-2007 19:46 (eg)
(define-syntax program
......@@ -39,5 +39,6 @@
(begin (cond-expand (requirement (program stuff ...)) ...)
(program more ...)))))
(export-syntax program)
(provide "srfi-7")
;;;;
;;;; srfi-9.stk -- SRFI-9 (Records)
;;;;
;;;; Copyright 1999-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;; Copyright 1999-2007 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;;
;;;; Permission to use, copy, modify, distribute,and license this
......@@ -15,7 +15,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 27-Sep-1999 13:06 (eg)
;;;; Last file update: 17-May-2004 23:16 (eg)
;;;; Last file update: 4-May-2007 19:38 (eg)
;;;;
......@@ -67,6 +67,7 @@
; Result for oplevel (if any)
(values (void) ',name)))))
(export-syntax define-record-type)
(provide "srfi-9")
#|
......
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@kaolin.unice.fr]
* Creation date: 12-May-1993 10:34
* Last file update: 10-Jan-2007 22:32 (eg)
* Last file update: 26-Apr-2007 18:21 (eg)
*/
......@@ -1596,6 +1596,14 @@ SCM STk_add2(SCM o1, SCM o2)
return o1;
}
//DEFINE_PRIMITIVE("fx+", fxplus, subr2, (SCM o1, SCM o2))
//{
// if (!INTP(o1)) STk_error("bad fixnum ~S", o1);
// if (!INTP(o2)) STk_error("bad fixnum ~S", o1);
// return MAKE_INT(INT_VAL(o1) + INT_VAL(o2));
//}
DEFINE_PRIMITIVE("+", plus, vsubr, (int argc, SCM *argv))
{
SCM res;
......@@ -3230,5 +3238,6 @@ int STk_init_number(void)
MAKE_INT(real_precision),
real_precision_conv);
// ADD_PRIMITIVE(fxplus);
return TRUE;
}
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