Commit b68570a5 authored by Erick Gallesio's avatar Erick Gallesio

.

parent 90472608
;;;;
;;;; _snow.stk -- A special version of _snow package (the one used by everybody)
;;;;
;;;; Copyright © 2006 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.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
;;;; the Free Software Foundation; either version 2 of the License, 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 program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 21-Dec-2006 14:55 (eg)
;;;; Last file update: 21-Dec-2006 17:31 (eg)
;;;;
(require "srfi-4") ;;//FIXME:
(define-module _snow
(export snow-raise snow-error snow-with-exception-catcher)
;;
;; Functions
;;
(define (snow-raise exc)
(raise exc))
(define (snow-with-exception-catcher catcher thunk)
(with-handler catcher (thunk)))
(define (snow-error msg . args)
(eprintf "*** SNOW ERROR -- ~A" msg)
(for-each (lambda (x) (eprintf " ~S" x))
args)
(eprintf "\n")
(raise (exception* snow-error-condition msg: msg args: args)))
;;
;; Exceptions
;;
(define-exception* snow-condition)
(define-exception* snow-type-check-condition
parent: snow-condition)
(define-exception* snow-error-condition
parent: snow-condition
msg
args))
;; ----------------------------------------------------------------------
;; Redefine all the symbols exported by _snow to the STklos module
;; so that STklos is in fact now a Snow interpreter
(%redefine-module-exports (find-module '_snow) (find-module 'STklos))
(provide "_snow")
;;;;
;;;; snow-exception.stk -- Snow exception implementation
;;;;
;;;; Copyright © 2006 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.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
;;;; the Free Software Foundation; either version 2 of the License, 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 program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 15-Dec-2006 15:15 (eg)
;;;; Last file update: 21-Dec-2006 17:29 (eg)
;;;;
;; ======================================================================
;; define-exception*
;; ======================================================================
(define-macro (define-exception* name . body)
(define (%define-exception->condition name parent slots)
(let ((pred (string->symbol (format "~a?" name)))
(constr (string->symbol (format "make-~a" name)))
(arg (gensym))
(val (gensym)))
`(begin
;; Build the condition
(define ,name (make-condition-type ',name
,(if parent parent '&condition)
',slots))
;; Build the predicate
(define (,pred ,arg)
(and (condition? ,arg) (condition-has-type? ,arg ,name)))
;; Export name constructor and predicate
(export ,name ,constr ,pred)
;; Build the readers and setters
(let ((module (current-module)))
(for-each (lambda (x)
(let ((reader (string->symbol (format "~a-~a" ',name x)))
(writer (string->symbol (format "~a-~a-set!"
',name x))))
;; reader
(%symbol-define reader
(lambda(,arg)
(condition-ref ,arg x x))
module)
;; writer
(%symbol-define writer
(lambda (,arg ,val)
(condition-set! ,arg x ,val))
module)
;; export reader and writer
(%module-export module (list reader writer))))
(struct-type-slots ,name)))
;; Build the toplevel result
(values (void) ',name))))
;;
;; body of define-exception*
;;
(let Loop ((body body)
(parent #f)
(fields '()))
(cond
((null? body)
(%define-exception->condition name parent (reverse! fields)))
((keyword? (car body))
(cond
((null? (cdr body))
(error "value expected after keyword ~S" (car body)))
((eq? (car body) parent:)
(Loop (cddr body) (cadr body) fields))
(else ;; ignore this keyword for STklos
(Loop (cddr body) parent fields))))
((symbol? (car body))
(Loop (cdr body)
parent
(cons (car body) fields)))
(else
(error "bad exception field expected ~S" (car body))))))
;; ======================================================================
;; exception*
;; ======================================================================
(define-macro (exception* name . args)
(let Loop ((args args)
(res '()))
(cond
((null? args)
`(make-condition ,name ,@res))
((and (pair? args)
(keyword? (car args))
(not (null? (cdr args)))
(Loop (cddr args)
(append! res
`(',(string->symbol (keyword->string (car args)))
,(cadr args))))))
(else (error "bad parameter ~S" args)))))
;;;;
;;;; snow-misc.stk -- Snow Misc features
;;;;
;;;; Copyright 2006 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.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
;;;; the Free Software Foundation; either version 2 of the License, 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 program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 21-Dec-2006 12:02 (eg)
;;;; Last file update: 21-Dec-2006 12:10 (eg)
;;;;
;; ======================================================================
;; define*
;; ======================================================================
(define-macro (define* def . args)
(cond
((symbol? def)
`(define ,def ,@args))
((and (pair? def) (memq (car def) '(unquote access*)))
`(define ,(cadr def) ,@args))
(else
`(define ,(srfi89->ext-lambda-proto def)
,@args))))
;; ======================================================================
;; define-macro*
;; ======================================================================
(define-macro (define-macro* . args)
`(define-macro ,@args))
;; ======================================================================
;; unquote / access*
;; ======================================================================
(define-macro (unquote var-or-set)
`(access* ,var-or-set))
(define-macro (access* var-or-set)
(cond
((symbol? var-or-set)
var-or-set)
((and (pair? var-or-set)
(eq? (car var-or-set) 'set!)
(pair? (cdr var-or-set)))
(let ((var (cadr var-or-set)))
(cond
((symbol? var)
`(set! ,var ,@(cddr var-or-set)))
((and (pair? var)
(memq (car var) '(access* unquote))
(pair? (cdr var))
(null? (cddr var)))
`(set! ,(cadr var) ,@(cddr var-or-set)))
(else
(error "access* syntax error")))))
(else
(error "access* syntax error"))))
;;;;
;;;; snow-stklos.stk -- Snow packages in STklos
;;;;
;;;; Copyright 2006 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.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
;;;; the Free Software Foundation; either version 2 of the License, 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 program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 11-Dec-2006 14:39 (eg)
;;;; Last file update: 21-Dec-2006 15:39 (eg)
;;;;
;; ======================================================================
;; package*
;; ======================================================================
(define-macro (package* name version . body)
`(begin
(define-module ,name
(require "_snow")
(define %%package-version ',version)
,@(package*-body-expand body))
(select-module ,name)))
(define (package*-body-expand body)
(match-case body
(((provide: . ?prov) . ?impl-reqs)
(append (package*-expand-provide prov)
(package*-expand-impl-require impl-reqs)))
(else
(package*-expand-impl-require body))))
(define (package*-expand-provide provide)
(map (lambda (x)
(match-case x
;; require: clause
((require: ?pkg)
(if (symbol? pkg)
`(require-for-syntax ,(symbol->string pkg))
(error "package name must be a symbol. It was: ~S" pkg)))
;; define*
((define* (?var . ?args))
`(export ,var))
((define* (?var . ?args) . ?rest)
`(begin
(define (,var . ,(srfi89->ext-lambda-proto args)) ,@rest)
(export ,var)))
((define* ?var)
`(export ,var))
((define* ?var ?value)
`(begin
(define ,var ,value)
(export ,var)))
;; define-macro*
((define-macro* . ?rest)
`(define-macro ,@rest))
;; define-record*
((define-record* ?name . ?rest)
(%define-record* name rest #t))
;; define-exception*
((define-exception* ?name . ?rest)
`(define-exception* ,name ,@rest))
;; else
(else
(error "Form ~S not implemented" x))))
provide))
(define (package*-expand-impl-require reqs)
(map (lambda (x)
(match-case x
;; require clause
((require: ?pkg)
(if (symbol? pkg)
`(begin
(require ,(symbol->string pkg))
(import ,pkg))
(error "package name must be a symbol. It was: ~S" pkg)))
;; Meta informations
(((? keyword?) . ?args)
(eprintf "J'ai vu le keyword ~S\n" x))
(else
(error "bad implementation requirement: ~S" x))))
reqs))
;;;;
;;;; snow-parameter.stk -- Snow parameters
;;;;
;;;; Copyright © 2006 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.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
;;;; the Free Software Foundation; either version 2 of the License, 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 program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 21-Dec-2006 11:52 (eg)
;;;; Last file update: 21-Dec-2006 17:11 (eg)
;;;;
(define-macro (define-parameter* name default :optional setter)
(let ((var (gensym))
(sname (string->symbol (format "~a-set!" name))))
`(begin
(define ,name (make-parameter ,default ,@(if setter (list setter) '())))
(define ,sname (lambda (val) (,name val)))
(void))))
;;;;
;;;; snow-record.stk -- Snow record support
;;;;
;;;; Copyright 2006 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.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
;;;; the Free Software Foundation; either version 2 of the License, 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 program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 21-Dec-2006 12:00 (eg)
;;;; Last file update: 21-Dec-2006 12:02 (eg)
;;;;
(define (%define-record->struct name parent slots exported?)
(let ((pred (string->symbol (format "~a?" name)))
(constr (string->symbol (format "make-~a" name)))
(arg (gensym))
(val (gensym)))
`(begin
;; Build the structure
(define ,name (make-struct-type ',name ,parent ',(map car slots)))
;; Build the constructor
(define (,constr . ,arg)
(apply make-struct ,name ,arg))
;; Build the predicate
(define (,pred ,arg)
(and (struct? ,arg) (struct-is-a? ,arg ,name)))
;; Build the slot readers
,@(map (lambda (x)
`(define ,(cadr x)
(lambda (,arg)
(%fast-struct-ref ,arg ,name ',(cadr x) ,(cadddr x)))))
slots)
;; Build the slot setters
,@(map (lambda (x)
`(define ,(caddr x)
(lambda (,arg ,val)
(%fast-struct-set! ,arg ,name ',(caddr x) ,(cadddr x) ,val))))
slots)
,(if exported?
`(export ,name ,constr ,pred
,@(map cadr slots)
,@(map caddr slots))
'(void))
;; Build the toplevel result
(values (void) ',name))))
(define (%define-record* name body exported?)
(let Loop ((body body)
(parent #f)
(fields '())
(offset 0))
(cond
((null? body)
(%define-record->struct name parent (reverse! fields) exported?))
((not (pair? body))
(error "bad record ~S" body))
((keyword? (car body))
(cond
((null? (cdr body))
(error "value expected after keyword ~S" (car body)))
((eq? (car body) parent:)
(Loop (cddr body) (cadr body) fields offset))
(else ;; ignore this keyword for STklos
(Loop (cddr body) parent fields offset))))
(else
(match-case (car body)
((? symbol?)
(let ((fld (car body)))
(Loop (cdr body)
parent
(cons (list fld
(string->symbol (format "~a-~a" name fld))
(string->symbol (format "~a-~a-set!" name fld))
offset)
fields)
(+ offset 1))))
(((? symbol?) (? symbol?) (? symbol?))
(let ((fld (caar body))
(getter (cadar body))
(setter (cadar body)))
(Loop (cdr body)
parent
(cons (list fld getter setter offset) fields)
(+ offset 1))))
(else
(error "bad record field ~S" (car body))))))))
(define-macro (define-record* name . body)
(%define-record* name body #f))
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 01-Jan-2000 15:04 (eg)
;;;; Last file update: 18-Dec-2006 21:34 (eg)
;;;; Last file update: 21-Dec-2006 18:24 (eg)
;;;;
(include "runtime.stk") ; Definition necessary for the bootstrap
......@@ -44,19 +44,20 @@
(import REPL)
;==============================================================================
(autoload "compfile" compile-file)
(autoload "describe" describe)
(syntax-autoload "match" match-case match-lambda)
(autoload "getopt" %print-usage)
(syntax-autoload "getopt" parse-arguments)
(syntax-autoload "trace" trace untrace)
(autoload "pp" pp pretty-print)
(autoload "env" null-environment scheme-report-environment
interaction-environment)
(autoload "srfi-27" random-integer random-real)
(autoload "compfile" compile-file)
(autoload "describe" describe)
(syntax-autoload "match" match-case match-lambda)
(autoload "getopt" %print-usage)
(syntax-autoload "getopt" parse-arguments)
(syntax-autoload "trace" trace untrace)
(autoload "pp" pp pretty-print)
(autoload "env" null-environment scheme-report-environment
interaction-environment)
;(syntax-autoload "snow-support" package*)
(autoload "srfi-27" random-integer random-real)
(syntax-autoload "srfi-34" with-exception-handler guard)
(syntax-autoload "srfi-35" define-condition-type condition)
(autoload "srfi-48" srfi48:help srfi48:format-fixed)
(autoload "srfi-48" srfi48:help srfi48:format-fixed)
;==============================================================================
;; Execute the REPL only if a file was not given on the command line
......
......@@ -21,13 +21,25 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 20-Dec-2006 10:18 (eg)
;;;; Last file update: 20-Dec-2006 10:42 (eg)
;;;; Last file update: 21-Dec-2006 15:44 (eg)
;;;;
;; ======================================================================
;; The SNOW STklos module
;; ======================================================================
(define-module SNOW
(include "Snow.d/snow-srfi89.stk")
(include "Snow.d/snow-exception.stk")
; (include "Snow.d/snow-record.stk")
; (include "Snow.d/snow-package.stk")
(include "Snow.d/snow-parameter.stk")
(include "Snow.d/snow-record.stk")
(include "Snow.d/snow-package.stk")
(include "Snow.d/snow-misc.stk")
)
;; ======================================================================
;; bootstrap
;; ======================================================================
(include "Snow.d/_snow.stk")
(provide "snow-support")
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