Lisp Macro for Lisp like Structures in Guile Scheme Interpreter

Guile has ugly structure implementaion. Here are sructure implementation for guile (using lisp like macros) which look more like common lisp structures.

(define (make-name name)
  "create struct constructor name."
  (string->symbol (string-append "make-" (symbol->string name))))

(define (make-getter name field)
  "create filed acess function name."
  (string->symbol (string-append (symbol->string name) "-"
				 (symbol->string field))))

(define (make-setter name field)
  "create field setter function name."
  (string->symbol (string-append "set-" 
				 (symbol->string name) "-"
				 (symbol->string field) "!")))

(define (make-predicate name)
  "create predicate function name."
  (string->symbol (string-append (symbol->string name) "?")))

(define-macro (defstruct name . fields)
  "Macro implementing structures in guile based on assoc list."
  (let ((names (map (lambda (symbol) (gensym)) fields))
        (struct (gensym))
        (field-arg (gensym)))
    `(if (not (every-unique ',fields))
        (error 'defstruct "Fields must be unique")
          (define (,(make-name name) ,@names)
        (map cons ',fields (list ,@names)))
          ,@(map (lambda (field)
               `(define (,(make-getter name field) ,struct)
              (cdr (assq ',field ,struct)))) fields)
          ,@(map (lambda (field)
               `(define (,(make-setter name field) ,struct ,field-arg)
                    (assq-set! ,struct ',field ,field-arg)
              ,field-arg)) fields)
          (define (,(make-predicate name) ,struct)
            (and (struct? ,struct) (equal? ',fields (map car ,struct))))))))

(define (unique item list)
  "check if item ocour only once."
  (= (length (filter (lambda (i) (eq? item i)) list)) 1))

(define (every predicate list)
  "check if every element in list return true for a given predicate."
  (let ((result #t))
    (for-each (lambda (x)
		(if (not (predicate x)) (set! result #f))) list)

(define (every-unique list)
  "check if every element ocour only once."
  (every (lambda (item) (unique item list)) list))

(define (struct? struct)
  "check if argument is structure (actualy it check if struct is alist with keys are symbols)."
  (and (list? struct) (every pair? struct) (every symbol? (map car struct))))

(define (last list)
  "return last element from the list."
  (let iter ((list list))
    (if (null? (cdr list))
	(car list)
	(iter (cdr list)))))

(define (write-struct struct)
  "print structure."
  (if (struct? struct)
	(display "#<")
	(for-each (lambda (field)
		    (let ((first (car field)))
		      (if (struct? first)
			  (write-struct first)
			  (display first)))
		    (display ":")
		    (let ((rest (cdr field)))
		      (if (struct? rest)
			  (write-struct rest)
			  (write rest)))
		    (if (not (eq? field (last struct)))
			(display " "))) struct)
	(display ">"))))

(define (print-struct struct)
  (write-struct struct)

This implementation use alist as structure. If you use defstruct macro it will define couple of function: constructor make-<struct name>, geters for every field <struct name>-<field name> seters for every field set-<struct name>-<field name>! and predicate <struct name>? which check if structure are of specific type.

You can use it like this

(defstruct point x y)
(define point (make-point 10 20))
(set-point-x! point 1)
(display (string-append "x: " (point-x point)))
(display (string-append "is struct?: " (if (struct? point) "true" "false")))
(display (string-append "is point?: " (if (point? point) "true" "false")))
(print-struct point)

You could download code here.


  1. Leave a comment

Leave a Reply

Fill in your details below or click an icon to log in: Logo

You are commenting using your account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s

%d bloggers like this: