evaluating a file with out side effects

evaluating a file with out side effects

[Thomas Mulcahy]

Hi, I'm attempting to use scheme to generate HTML for
a page like this:
http://okmij.org/ftp/Scheme/xml.scm
(See http://okmij.org/ftp/Scheme/xml.html for the HTML
version).
To do this, I need to evaluate the contents of a file
and get the result. The guile load procedure returns
unspecified however, instead of the result of
evaluating the file. I can see how it would be
possible to evaluate each s-expression in the file but
this seems a bit awkward and would have side effects
(definitions in the file might overwrite my own
definitions). What is the best way to do this?

Thanks,
Thomas

______________________________________________________________________ 
Post your free ad now! http://personals.yahoo.ca


_______________________________________________
Guile-user mailing list
Guile-user@gnu.org
http://mail.gnu.org/mailman/listinfo/guile-user

Re: evaluating a file with out side effects

[Arno Peters]

[-- Attachment #1.1.1: Type: text/plain, Size: 1412 bytes --]

On Sun, Jun 01, 2003 at 08:25:26PM -0400, Thomas Mulcahy wrote:
> Hi, I'm attempting to use scheme to generate HTML for
> a page like this:
> http://okmij.org/ftp/Scheme/xml.scm
> (See http://okmij.org/ftp/Scheme/xml.html for the HTML
> version).

> To do this, I need to evaluate the contents of a file
> and get the result. The guile load procedure returns
> unspecified however, instead of the result of
> evaluating the file. I can see how it would be
> possible to evaluate each s-expression in the file but
> this seems a bit awkward and would have side effects
> (definitions in the file might overwrite my own
> definitions). What is the best way to do this?

SSAX uses the function SRV:send-reply to display the list of
fragments.  At the end of xml.scm, you see:

  (define (generate-HTML Content)
   (SRV:send-reply
    (pre-post-order Content
     (generic-web-rules Content '()))))
  
  (generate-HTML Content)

Note that the variable Content in the last line contains the SXML
expressions that are to be transformed into HTML.  Perhaps these lines
are missing from your file?

You may run into some problems using SSAX with Guile directly from the
CVS repository. I use the two attached files to integrate SSAX into
Guile.  Use these files if you like to get SSAX to work for you, they
are hereby released into the public domain.

Regards,
-- 
Arno Peters



[-- Attachment #1.1.2: myenv-guile.scm --]
[-- Type: text/plain, Size: 10719 bytes --]

; 			My Standard Scheme "Prelude"
; Version for SCM v5d2
; $Id: myenv-scm.scm,v 1.2 2001/09/21 19:53:30 oleg Exp $
(use-modules (ice-9 slib))

		; Very SCM-specific definitions
(defmacro define-macro (bindings . body)
  (if (pair? bindings)
      `(defmacro ,(car bindings) ,(cdr bindings) ,@body)
      (let ((rest (gensym)))
	`(defmacro ,bindings ,rest (apply ,@body ,rest)))))


(define-macro (include file) 
  (if (equal? file "myenv.scm")
      '(begin #f)
      `(load ,file)))

(define pp display)

(define-macro (declare . x) '(begin #f)) ; Gambit-specific compiler-decl

; Support for let*-values form

(require 'values)

; Like let* but allowing for multiple-value bindings
(define-macro (let*-values bindings . body)
  (if (null? bindings) (cons 'begin body)
      (apply (lambda (vars initializer)
	 (let ((cont 
		(cons 'let*-values 
		      (cons (cdr bindings) body))))
	   (cond
	    ((not (pair? vars))		; regular let case, a single var
	     `(let ((,vars ,initializer)) ,cont))
	    ((null? (cdr vars))		; single var, see the prev case
	     `(let ((,(car vars) ,initializer)) ,cont))
	   (else			; the most generic case
	    `(call-with-values (lambda () ,initializer)
	      (lambda ,vars ,cont))))))
       (car bindings))))

; A few convenient functions that are not SCM
(define (with-input-from-string str thunk)
  (call-with-input-string str
			  (lambda (port)
			    (with-input-from-port port thunk))))
(define (open-input-string str)
  (call-with-current-continuation
   (lambda (k)
     (call-with-input-string str
			     (lambda (port) (k port))))))
(define (with-output-to-string thunk)
  (call-with-output-string
   (lambda (port)
     (with-output-to-port port thunk))))

; assert the truth of an expression (or of a sequence of expressions)
;
; syntax: assert ?expr ?expr ... [report: ?r-exp ?r-exp ...]
;
; If (and ?expr ?expr ...) evaluates to anything but #f, the result
; is the value of that expression.
; If (and ?expr ?expr ...) evaluates to #f, an error is reported.
; The error message will show the failed expressions, as well
; as the values of selected variables (or expressions, in general).
; The user may explicitly specify the expressions whose
; values are to be printed upon assertion failure -- as ?r-exp that
; follow the identifier 'report:'
; Typically, ?r-exp is either a variable or a string constant.
; If the user specified no ?r-exp, the values of variables that are
; referenced in ?expr will be printed upon the assertion failure.

(define-macro (assert expr . others)
			; given the list of expressions or vars,
			; make the list appropriate for cerr
  (define (make-print-list prefix lst)
    (cond
     ((null? lst) '())
     ((symbol? (car lst))
      (cons #\newline
	(cons (list 'quote (car lst))
	  (cons ": " (cons (car lst) (make-print-list #\newline (cdr lst)))))))
     (else 
      (cons prefix (cons (car lst) (make-print-list "" (cdr lst)))))))

			; return the list of all unique "interesting"
			; variables in the expr. Variables that are certain
			; to be bound to procedures are not interesting.
  (define (vars-of expr)
    (let loop ((expr expr) (vars '()))
      (cond
       ((not (pair? expr)) vars)	; not an application -- ignore
       ((memq (car expr) 
	      '(quote let let* letrec let*-values lambda cond quasiquote
		      case define do assert))
	vars)				; won't go there
       (else				; ignore the head of the application
	(let inner ((expr (cdr expr)) (vars vars))
	  (cond 
	   ((null? expr) vars)
	   ((symbol? (car expr))
	    (inner (cdr expr)
		   (if (memq (car expr) vars) vars (cons (car expr) vars))))
	   (else
	    (inner (cdr expr) (loop (car expr) vars)))))))))

  (cond
   ((null? others)		; the most common case
    `(or ,expr (begin (cerr "failed assertion: " ',expr nl "bindings"
			    ,@(make-print-list #\newline (vars-of expr)) nl)
		      (error "assertion failure"))))
   ((eq? (car others) 'report:) ; another common case
    `(or ,expr (begin (cerr "failed assertion: " ',expr
			    ,@(make-print-list #\newline (cdr others)) nl)
		      (error "assertion failure"))))
   ((not (memq 'report: others))
    `(or (and ,expr ,@others)
	 (begin (cerr "failed assertion: " '(,expr ,@others) nl "bindings"
		      ,@(make-print-list #\newline
			 (vars-of (cons 'and (cons expr others)))) nl)
		      (error "assertion failure"))))
   (else			; report: occurs somewhere in 'others'
    (let loop ((exprs (list expr)) (reported others))
      (cond
       ((eq? (car reported) 'report:)
	`(or (and ,@(reverse exprs))
	     (begin (cerr "failed assertion: " ',(reverse exprs)
			  ,@(make-print-list #\newline (cdr reported)) nl)
		    (error "assertion failure"))))
       (else (loop (cons (car reported) exprs) (cdr reported)))))))
)
    
(define-macro (assure exp error-msg) `(assert ,exp report: ,error-msg))

(define (identify-error msg args . disposition-msgs)
  (let ((port (current-error-port)))
    (newline port)
    (display "ERROR" port)
    (display msg port)
    (for-each (lambda (msg) (display msg port))
	      (append args disposition-msgs))
    (newline port)))

; like cout << arguments << args
; where argument can be any Scheme object. If it's a procedure
; (without args) it's executed rather than printed (like newline)

(define (cout . args)
  (for-each (lambda (x)
              (if (procedure? x) (x) (display x)))
            args))

(define (cerr . args)
  (for-each (lambda (x)
              (if (procedure? x)
		  (x (current-error-port))
		  (display x (current-error-port))))
            args))

;(##define-macro (nl) '(newline))
(define nl (string #\newline))

; Some useful increment/decrement operators
; Note, ##fixnum prefix is Gambit-specific, it means that the
; operands assumed FIXNUM (as they ought to be anyway).
; This perfix could be safely removed: it'll leave the code just as
; correct, but more portable (and less efficient)

				; Mutable increment
(define-macro (++! x) `(set! ,x (+ 1 ,x)))

				; Read-only increment
(define-macro (++ x) `(+ 1 ,x))

				; Mutable decrement
(define-macro (--! x) `(set! ,x (- ,x 1)))

				; Read-only decrement
(define-macro (-- x) `(- ,x 1))

; Some useful control operators

			; if condition is true, execute stmts in turn
			; and return the result of the last statement
			; otherwise, return #f
(define-macro (when condition . stmts)
  `(and ,condition (begin ,@stmts)))
  

			; if condition is false execute stmts in turn
			; and return the result of the last statement
			; otherwise, return #t
			; This primitive is often called 'unless'
(define-macro (whennot condition . stmts)
  `(or ,condition (begin ,@stmts)))


			; Execute a sequence of forms and return the
			; result of the _first_ one. Like PROG1 in Lisp.
			; Typically used to evaluate one or more forms with
			; side effects and return a value that must be
			; computed before some or all of the side effects happen.
(define-macro (begin0 form . forms)
  (let ((var (gensym)))
    `(let ((,var ,form)) ,@forms ,var)))

			; Prepend an ITEM to a LIST, like a Lisp macro PUSH
			; an ITEM can be an expression, but ls must be a VAR
(define-macro (push! item ls)
  `(set! ,ls (cons ,item ,ls)))

			; Is str the empty string?
			; string-null? str -> bool
			; See Olin Shiver's Underground String functions
(define-macro (string-null? str) `(zero? (string-length ,str)))


			; assoc-primitives with a default clause
			; If the search in the assoc list fails, the
			; default action argument is returned. If this
			; default action turns out to be a thunk,
			; the result of its evaluation is returned.
			; If the default action is not given, an error
			; is signaled

(define-macro (assq-def key alist . default-action-arg)
  (let ((default-action
        (if (null? default-action-arg)
          `(error "failed to assq key '" ,key "' in a list " ,alist)
          (let ((defact-symb (car default-action-arg)))
            `(if (procedure? ,defact-symb) (,defact-symb) ,defact-symb)))))
    `(or (assq ,key ,alist) ,default-action)))

(define-macro (assv-def key alist . default-action-arg)
  (let ((default-action
        (if (null? default-action-arg)
          `(error "failed to assv key '" ,key "' in a list " ,alist)
          (let ((defact-symb (car default-action-arg)))
            `(if (procedure? ,defact-symb) (,defact-symb) ,defact-symb)))))
    `(or (assv ,key ,alist) ,default-action)))

(define-macro (assoc-def key alist . default-action-arg)
  (let ((default-action
        (if (null? default-action-arg)
          `(error "failed to assoc key '" ,key "' in a list " ,alist)
          (let ((defact-symb (car default-action-arg)))
            `(if (procedure? ,defact-symb) (,defact-symb) ,defact-symb)))))
    `(or (assoc ,key ,alist) ,default-action)))


			; Convenience macros to avoid quoting of symbols
			; being deposited/looked up in the environment
(define-macro (env.find key) `(%%env.find ',key))
(define-macro (env.demand key) `(%%env.demand ',key))
(define-macro (env.bind key value) `(%%env.bind ',key ,value))


			; Implementation of SRFI-0
			; Only feature-identifiers srfi-0 and scm
			; assumed predefined
(define-macro (cond-expand . clauses)
  (define feature-ids '(scm srfi-0))
  (define (feature-req-satisfies? fr) ; does feature-request satisfies?
    (cond
     ((memq fr feature-ids) #t)
     ((not (pair? fr)) #f)
     ((eq? 'and (car fr))
      (let loop ((clauses (cdr fr)))
	(or (null? clauses)
	    (and (feature-req-satisfies? (car clauses))
		 (loop (cdr clauses))))))
     ((eq? 'or (car fr))
      (let loop ((clauses (cdr fr)))
	(and (pair? clauses)
	     (or (feature-req-satisfies? (car clauses))
		 (loop (cdr clauses))))))
     ((eq? 'not (car fr))
      (not (feature-req-satisfies? (and (pair? (cdr fr)) (cadr fr)))))
     (else #f)))
  (let loop ((clauses clauses))
    (if (null? clauses) '(error "Unfulfilled cond-expand")
	(let* ((feature-req (if (pair? (car clauses)) (caar clauses)
				(error "<cond-expand clause> is not a list")))
	       (cmd-or-defs* (cons 'begin (cdar clauses))))
	  (cond
	   ((and (eq? 'else feature-req) (null? (cdr clauses)))
	    cmd-or-defs*)
	   ((feature-req-satisfies? feature-req)
	    cmd-or-defs*)
	   (else (loop (cdr clauses))))))))

(define (parser-error port message . specialising-msgs)
  (apply cerr (cons message specialising-msgs))
  (cerr nl)
  (exit 4))

(define (OS:file-length file)
  (stat:size (stat file)))

[-- Attachment #1.1.3: sxml.scm --]
[-- Type: text/plain, Size: 908 bytes --]

(define-module (sxml sxml)
  :use-module (srfi srfi-13))

(load "myenv-guile.scm")
(load "char-encoding.scm")
(load "look-for-str.scm")
(load "input-parse.scm")
(load "util.scm")
(load "SSAX.scm")
(load "SXML-tree-trans.scm")
(load "SXML-to-HTML.scm")
(load "SXML-to-HTML-ext.scm")

(export-syntax let*-values)
(export post-order
	SXML->HTML
	string->goodHTML
	entag
	enattr
	lookup-def
	nl
	list-intersperse
	make-navbar
	make-header
	make-footer

	pre-post-order
	post-order
	generic-web-rules

	SRV:send-reply

	ssax:make-parser
	ssax:make-elem-parser
	ssax:scan-Misc
	xml-token-kind
	xml-token-head
	assert-curr-char
	ssax:S-chars
	ssax:skip-S
	ssax:read-QName
	ssax:ncname-starting-char?
	ssax:read-external-id
	ssax:make-pi-parser
	ssax:skip-pi
	ssax:Prefix-XML
	ssax:complete-start-tag
	ssax:read-char-data
	ssax:assert-token
	when
	ssax:handle-parsed-entity
	ssax:predefined-parsed-entities

	cerr
)

[-- Attachment #1.2: Type: application/pgp-signature, Size: 189 bytes --]

[-- Attachment #2: Type: text/plain, Size: 139 bytes --]

_______________________________________________
Guile-user mailing list
Guile-user@gnu.org
http://mail.gnu.org/mailman/listinfo/guile-user