guile-hurd/hurd-cl-compat.scm

(define-module (hurd-cl-compat)
  ;; Common Lisp functions, syntax and variables
  #:export (in-package defvar defconstant
		       defgeneric defun
		       defmethod defmacro
		       defclass
		       setf
		       t
		       progn
		       (eval-when/common-lisp . eval-when)
		       (case/common-lisp . case)
		       (reduce/common-lisp . reduce)
		       (concatenate/common-lisp . concatenate)
		       mapcar
		       flet
		       nil
		       declare
		       loop
		       boole
		       multiple-value-bind
		       destructuring-bind
		       check-type
		       ;; Some predicates
		       typep
		       ;; Common Lisp bitwise functions (also see #:re-export)
		       boole-1
		       boole-2
		       boole-andc1
		       boole-andc2
		       boole-c1
		       boole-c2
		       boole-clr
		       boole-nor
		       boole-orc1
		       boole-orc2
		       boole-set
		       ;; List manipulation
		       pushnew
		       remove-if
		       ;; Hash table operations
		       gethash
		       ;; Conditions
		       warning style-warning define-condition
		       ;; Not Common Lisp, but still useful
		       define-report
		       syntax-map syntax-car
		       syntax-cdr syntax-cadr
		       list-syntax->syntax-list
		       loop*
		       case/scheme) ; <-- XXX case/common-lisp should suffice
  ;; Predicates and comparison operators?
  #:re-export ((null? . null)
	       (zero? . zerop)
	       (number? . numberp)
	       (symbol? . symbolp)
	       (string? . stringp)
	       (char? . charp)
	       (eq? . eq)
	       (eqv? . eql)
	       (positive? . plusp) ; > 0
	       ;; CL has equal and equalp,
	       ;; where (equal 3 3.0) but not (equalp 3 3.0).
	       ;; Let's silently use the latter behaviour and
	       ;; hope nothhing notices.  Likewise for eql.
	       (equal? . equal)
	       (equal? . equalp)
	       ;; Bitwise operations
	       (bitwise-ior . boole-ior)
	       (bitwise-and . boole-and)
	       (bitwise-xor . boole-xor)
	       ;; Hash-Table operations
	       (rnrs:make-eqv-hashtable . make-hashtable))
  #:replace (defmacro
	      (eval-when/common-lisp . eval-when)
	      (case/common-lisp . case)
	      (concatenate/common-lisp . concatenate)
	      reduce)
  #:use-module ((rnrs base) #:select (assert))
  #:use-module (oop goops)
  #:use-module (srfi srfi-1)
  ;; Procedural interface to (rnrs conditions)
  #:use-module ((srfi srfi-35) #:prefix srfi:)
  #:use-module ((rnrs hashtables) #:prefix rnrs:)
  #:use-module (rnrs arithmetic fixnums)
  #:use-module (rnrs arithmetic bitwise)
  #:use-module (ice-9 receive)
  #:use-module (rnrs conditions))

;; Common Lisp -- Scheme compatibility,
;; fudging over many details.

;; XXX recognise foreign-enum, foreign-type, ...
(define-syntax typep
  (lambda (s)
    (syntax-case s (quote integer fixnum character string)
      ((_ object 'integer) #'(integer? object))
      ((_ object 'fixnum) #'(fixnum? object))
      ((_ object 'character) #'(character? object))
      ((_ object 'string) #'(string? object))
      (_ #'(XXX-implement #{perhaps a hash table for clos goops!}#)))))


;; Hash tables
(define gethash
  (let ((v (cons #nil #nil)))
    ;; ^ not seen, merely an unique object to determine the hash table
    ;; does not have a certain key!
    (make-procedure-with-setter
     (lambda* (key hash-table #:optional (default #nil))
       (receive (result)
	   (rnrs:hashtable-ref hash-table v)
	 (if (eq? result v)
	     (values default #nil)
	     (values result  #true))))
     (case-lambda
       ((key hash-table new-value)
	(hash-table-set! hash-table key new-value)
	(values))
       ((key hash-table default new-value)
	(hash-table-set! hash-table key new-value)
	(values))))))


;; Boolean.  See
;; https://www.cs.utexas.edu/users/moore/acl2/manuals/current/manual/index-seo.php/ACL2____BOOLE_42
(define (boole-1 x y)
  (assert (exact-integer? x))
  (assert (exact-integer? y))
  x)

(define (boole-2 x y)
  (assert (exact-integer? x))
  (assert (exact-integer? y))
  x)

(define (boole-andc2 x y)
  (bitwise-and x (bitwise-not y)))

(define (boole-andc1 x y)
  (bitwise-and (bitwise-not x) y))

(define (boole-c1 x y)
  (assert (exact-integer? x))
  (assert (exact-integer? y))
  (bitwise-not x))

(define (boole-c2 x y)
  (assert (exact-integer? x))
  (assert (exact-integer? y))
  (bitwise-not y))

(define (boole-clr x y)
  (assert (exact-integer? x))
  (assert (exact-integer? y))
  0)

(define (boole-set x y)
  (assert (exact-integer? x))
  (assert (exact-integer? y))
  -1)

(define (boole-nor x y)
  (bitwise-not (bitwise-ior x y)))

(define (boole-orc1 x y)
  (bitwise-ior (bitwise-not x) y))

(define (boole-orc2 x y)
  (bitwise-ior x (bitwise-not y)))

(define-syntax-rule (pushnew item var)
  (let ((old var)
	(val item))
    (if (memq val old)
	old
	(begin (set! var (cons item old))
	       old))))

(define* (remove-if test sequence)
  (if (vector? sequence)
      (list->vector (remove-if test (vector->list sequence)))
      (filter (negate test) sequence)))



;; Warning: syntax cannot (currently) be re-exported!
;; If you try, you'll end up with "Wrong type to apply: #<syntax-transformer case/scheme>".
(define nil #nil)

(define* (reduce/common-lisp proc ls #:key initial-value)
  (reduce proc initial-value ls))

(define (concatenate/common-lisp type . stuff)
  (case type
    ((string) (apply string-append stuff))))

(define-syntax declare
  (syntax-rules (type fixnum ignore)
    ((_ (type fixnum x ...))
     (begin
       (assert (fixnum? x))
       ...))
    ((_ (ignore stuff))
     (begin))))

(define-syntax type-exp-predicate
  (lambda (s)
    (syntax-case s (and not null symbol)
      ((_ symbol) #'symbol?)
      ((_ (and x y))
       #'(lambda (z) (and ((type-exp-predicate x) z)
			  ((type-exp-predicate y) z))))
      ((_ (not x))
       #'(lambda (z) (not ((type-exp-predicate x) z))))
      ((_ null) null?)
      ;; XXX why won't ((_ symbol) #'symbol?) work?
      ((_ rest) (eq? (syntax->datum #'rest) 'symbol)
       #'(lambda (x)
	   (or (symbol? x)
	       ;; Common Lisp symbols starting with : are mapped to Scheme keyword objects.
	       (keyword? x))))
      ;; XXX likewise
      ((_ rest) (eq? (syntax->datum #'rest) 'null)
       #'null?))))

(define-syntax-rule (check-type var type-exp)
  (assert ((type-exp-predicate type-exp) var)))

(define-syntax eval-when/common-lisp
  (lambda (s)
    (define (eval-when-cl->scheme s)
      (syntax-case s (compile load eval expand)
	(#:compile-toplevel #'compile)
	(compile #'compile)
	(#:load-toplevel #'load)
	(load #'load)
	(#:execute #'eval)
	(eval #'eval)
	(expand #'expand)))
    (syntax-case s ()
      ((_ x exp exp* ...)
       #`(eval-when
	     #,(map eval-when-cl->scheme
		    (list-syntax->syntax-list #'x))
	   exp exp* ...)))))

(define-syntax case/common-lisp
  (syntax-rules (otherwise)
    ((_ what (otherwise stuff ...)) (begin stuff ...))
    ((_ what (x y))
     ;; XXX what does Common Lisp prescribe
     ;; in case there is no match?
     (case what
       ((x) y)))
    ((_ what (x y) . rest)
     (let ((save what))
       (if (eq? save 'x)
	   y
	   (case/common-lisp save . rest))))))

;; TODO

(define (boole x y z)
  0 ; <-- due to reasons, needs to be removed later
  #;(error "todo, implement!/4" x y))
(define boole-ior 'todo)
(define boole-and 'todo)

(define-syntax setf
  (syntax-rules ()
    ((_ var value)
     (set! var value))
    ((_ var value var* value* . rest)
     (begin
       (set! var value)
       (setf var* value* . rest)))))

(define-syntax-rule (progn x x* ...)
  (begin x x* ...))

(define-syntax-rule (flet ((proc args exp) ...)
			  exp^ exp^* ...)
  (let ((proc (lambda args exp)) ...)
    exp^ exp^* ...))

(define t #t)
(define-syntax loop*
  (syntax-rules ()
    ((_ (((x ...) #:in x^) . etc) #:do . rest)
     (for-each
      (lambda (obj)
	(apply (lambda (x ...)
		 (loop* etc #:do . rest)) obj))
      x^))
    ((_ ((x #:in x^) . etc) #:do . rest)
     (for-each
      (lambda (x)
	(loop* etc #:do . rest))
      x^))
    ((_ ((i #:from a #:below b))
	#:collect exp)
     (let ((from a) (to/exclusive b))
       (let loop ((i from))
	 (if (< i to/exclusive)
	     (cons exp (loop (1+ i)))
	     #nil))))
    ((_ () #:do . rest)
     (begin . rest))
    ((_ ((x #:in x^)) #:sum exp)
     (let loop ((total 0) (todo x^))
       (if (null? todo)
	   total
	   (loop (+ total (let ((x (car todo))) exp))
		 (cdr todo)))))
    ((_ #:until stop?
	#:collect expression)
     (let loop ()
       (if stop?
	   '()
	   (let ((e expression))
	     (cons e (loop))))))
    ((_ #:until stop?
	#:do stuff
	#:finally (#:return tail-position))
     (let loop ()
       (if stop?
	   tail-position
	   (loop))))))

(define-syntax loop
  (syntax-rules (for in do collect from below while until finally return)
    ((_ for i from a below b collect exp)
     (loop* ((i #:from a #:below b)) #:collect exp))
    ((_ for x in list do stuff)
     (loop* ((x #:in list)) #:do stuff))
    ((_ until stop? collect stuff)
     (loop* #:until stop? #:collect stuff))
    ((_ until stop? do stuff finally (return tail-position))
     (loop* #:until stop? #:do stuff #:finally (#:return tail-position)))))

;; We ignore the variable / function
;; distinction.
(define-syntax defvar
  (syntax-rules ()
    ((_ name)
     (define name))
    ((_ name value)
     (define name value))
    ((_ name value documentation)
     (define name value))))

(define-syntax defconstant
  (syntax-rules ()
    ((_ name value)
     (define-syntax name (identifier-syntax value)))
    ((_ name value doc)
     (define-syntax name (identifier-syntax value)))))

(define (syntax-cadr s)
  "Like cadr, but for syntax"
  (syntax-case s ()
    ((_ . (x . y)) #'x)))

(define (syntax-car s)
  "Like car, but for syntax"
  (syntax-case s ()
    ((x . y) #'x)))

(define (syntax-cdr s)
  "Like cdr, but for syntax"
  (syntax-case s ()
    ((x . y) #'y)))

(define (syntax-map proc s)
  "Like map, but for syntax"
  (syntax-case s ()
    (() #'())
    ((x . rest) (cons (proc #'x) (syntax-map proc #'rest)))))

;; Dotted lists are allowed, in which case the component
;; after the dot is preserved.  (But currently only if
;; what's after the dot, is an identifier, to avoid silently
;; introducing bugs.)
(define (list-syntax->syntax-list s)
  (syntax-case s ()
    (() '())
    ((x . rest) (cons #'x (list-syntax->syntax-list #'rest)))
    (x (identifier? #'x) #'x)))

(define (syntax->maybe-keyword s)
  (let ((d (syntax->datum s)))
    (if (keyword? d)
	d
	s)))

(define-syntax-rule (defgeneric name (arg ...) . extra)
  (define-generic name))

(define-syntax destructuring-bind
  (lambda (s)
    (syntax-case s ()
      ((_ () exp exp* exp** ...)
       #'(apply (lambda () exp* exp** ...) exp))
      ((_ rest exp exp* exp** ...)
       (identifier? #'rest)
       #'(let ((rest exp)) exp* exp** ...))
      ((_ (x . rest) exp exp* exp** ...)
       (identifier? #'x)
       #'(let* ((args exp))
	   (destructuring-bind rest (cdr args) exp* exp** ...))))))

(define-syntax-rule (multiple-value-bind args exp exp* ...)
  (receive args exp exp* ...))

;; Specialises in the first argument

(eval-when (load compile eval)
  (define (cl->schemy-lambda*-list syntax-list)
    (syntax-case syntax-list (&key &optional &rest &body)
      (() #'())
      ((&key . tail)
       #`(#:key . #,(cl->schemy-lambda*-list #'tail)))
      ((&optional . tail)
       #`(#:optional . #,(cl->schemy-lambda*-list #'tail)))
      ((&rest r)
       #`(#:rest r))
      ;; XXX this is used in defmacro forms sometimes
      ;; instead of &rest.  Does it mean the same thing?
      ((&body r)
       #`(#:rest r))
      ((something . tail)
       #`(something . #,(cl->schemy-lambda*-list #'tail)))
      (rest (identifier? #'rest) #'rest))))

(define-syntax defun
  (lambda (s)
    (syntax-case s ()
      ((_ name args exp exp* ...)
       (with-syntax ((binders (cl->schemy-lambda*-list #'args)))
	 #'(define* (name . binders)
	     exp exp* ...))))))

;; Guile's (oop goops) does not support keyword argument methods.
;; Emulate it with rest arguments. (defmethod)

(define (split-keyword-arguments argument-list)
  "Split @var{argument-list} into a syntax list of positional arguments
and a syntax list of keyword arguments."
  (syntax-case argument-list (&key &rest &optional &body)
    (() (values #'() #'()))
    ((&key . stuff) (values #'() argument-list))
    ((&rest . stuff) (values #'() argument-list))
    ((&body . stuff) (values #'() argument-list))
    ((x . more)
     (receive (positional keywordial)
	 (split-keyword-arguments #'more)
       (values #`(x . #,positional)
	       keywordial)))))

(define-syntax defmethod
  (lambda (s)
    (syntax-case s (setf)
      ((_ (setf accessor) . rest)
       #'(defmethod (setter accessor) . rest))
      ;; XXX these aren't exact matches to CLOS object system.
      ;;   1. only the most specific around-method should be called.
      ;;   3. the after methods should be called from least specific
      ;;      to most specific.
      ((_ name #:after args . rest)
       #'(defmethod name args
	   (next-method)
	   . rest))
      ((_ name #:before args . rest)
       #'(defmethod name args
	   (begin . rest)
	   (next-method)))
      ((_ name #:around args . rest)
       #'(defmethod name args . rest))
      ((_ name ((first (eql obj)) . rest) exp exp* ...)
       ;; XXX for some reason including eql in the literal
       ;; list won't work
       (eq? 'eql (syntax->datum #'eql))
       #'(define-method (name first . rest)
	   (if (eq? first obj)
	       (begin exp exp* ...)
	       (next-method))))
      ((_ name arguments exp exp* ...)
       (receive (positional keywordial)
	   (split-keyword-arguments #'arguments)
	 (syntax-case keywordial ()
	   (()
	    ;; No keyword arguments --> trivial
	    #`(define-method (name . arguments) exp exp* ...))
	   ((x . y)
	    ;; Some keyword arguments --> rest argument
	    (with-syntax ((binders (cl->schemy-lambda*-list keywordial)))
	      #`(define-method (name #,@positional . rest*)
		  (apply (lambda* binders exp exp* ...)
			 rest*))))))))))

;; Like defmacro, but with define instead of define-syntax.
;; Also don't eat the first component.
(define-syntax defnotmacro
  (lambda (s)
    (syntax-case s ()
      ((_ name kw-args exp exp* ...)
       (with-syntax ((binders (cl->schemy-lambda*-list #'kw-args)))
	 #`(define (name s*)
	     (apply (lambda* binders exp exp* ...)
		    ;; XXX maybe too many arguments are converted
		    (map syntax->maybe-keyword
			 (list-syntax->syntax-list s*)))))))))

(define-syntax defmacro
  (lambda (s)
    (syntax-case s ()
      ((_ name kw-args exp exp* ...)
       (with-syntax ((binders (cl->schemy-lambda*-list #'kw-args)))
	 #`(define-syntax name
	     (lambda (s*)
	       (defnotmacro proc kw-args exp exp* ...)
	       (syntax-case s* ()
		 ((_ . rest) (proc #'rest))))))))))

(define (mapcar proc . lists)
  (if (any null? lists)
      #nil
      (let* ((heads (map car lists))
	     (tails (map cdr lists))
	     (first (apply proc heads)))
	(cons first (apply mapcar proc tails)))))

(defnotmacro clos-field-syntax->goops (ptr &key
					   initform
					   initarg accessor
					   reader
					   documentation)
  #`(#,ptr #:init-keyword #,initarg
	   #,@(if accessor #`(#:accessor #,accessor) #'())
	   #,@(if initform #`(#:init-form #,initform) #'())
	   #,@(if reader #`(#:getter #,reader) #'())
	   #:documentation #,documentation))

(define-syntax defclass
  (lambda (s)
    (syntax-case s ()
      ((_ name supers
	  fields
	  . unsupported-cl-stuff)
       #`(define-class name supers
	   #,@(syntax-map clos-field-syntax->goops #'fields))))))

;; Conditions
(define-generic report)
(define-generic make-cl-condition)

(define-syntax-rule (define-report ((condition &type) stream) exp exp* ...)
  (define-method (report condition stream)
    (if ((condition-predicate &type) condition)
	(begin exp exp* ...)
	(next-method))))

(defnotmacro define-cl-condition-field-accessors (type name &key
						       initarg
						       initform
						       accessor
						       reader
						       documentation)
  #`(begin
      ;; TODO other fields
      #,@(if reader
	     #`((define (reader c)
		  (assert (srfi:condition-has-type? c #,type))
		  (srfi:condition-ref c '#,name)))
	     #'())))

(define-syntax cl->srfi-initargs
  (lambda (s)
    ;; A list ((field-A . #:the-initarg) ...),
    ;; where FWIW field-A is a syntax (it will be quoted,
    ;; not bound to a variable.)
    (define (cl-field->cl-field-names+initargs cl)
      (syntax-case cl ()
	((field-name . rest)
	 (let loop ((rest #'rest))
	   (syntax-case rest ()
	     ((#:initform form . rest)
	      (format (current-warning-port)
		      "initforms for conditions are unsupported (field: ~a)~%"
		      (syntax->datum #'field-name))
	      (loop #'rest))
	     ((#:accessor form . rest)
	      (format (current-warning-port)
		      "accessors for conditions are unsupported (field: ~a)~%"
		      (syntax->datum #'field-name))
	      (loop #'rest))
	     ((#:initarg ia . rest)
	      (keyword? (syntax->datum #'ia))
	      #`((field-name . #,(datum->syntax #'ia
						(keyword->symbol
						 (syntax->datum #'ia))))
		 . #,(loop #'rest)))
	     ((other r . rest)
	      (memq (syntax->datum #'rest) '(#:reader #:documentation))
	      (loop #'rest)))))))
    (define (names+initargs->argument-names names)
      (syntax-map syntax-cdr names))
    (define (names+initargs->srfi-list names+initargs)
      (syntax-case names+initargs ()
	(() #'())
	;; XXX verify this #:initarg for?
	(((name . initarg) . rest)
	 #`(name ,initarg . #,(names+initargs->srfi-list #'rest)))))
    (syntax-case s ()
      ((_ fields arguments)
       (let* ((names+initargs
	       (syntax-map cl-field->cl-field-names+initargs #'fields))
	      (argument-names (names+initargs->argument-names names+initargs))
	      (srfi-list (names+initargs->srfi-list names+initargs)))
	 #`(apply (lambda* (#:key . #,argument-names)
		    `#,srfi-list)
		  arguments))))))

(define-syntax srfi-ify-supertype
  (lambda (s)
    ;; TODO: adding error to the literal
    ;; list doesn't work.
    (syntax-case s ()
      ((_ name)
       (case (syntax->datum #'name)
	 ((error) #'&error)
	 (else #'name))))))

(define-syntax define-condition
  (lambda (s)
    (syntax-case s ()
      ((_ type (supertype)
	  ((field-key . r) ...)
	  . rest)
       #`(begin
	   (define type
	     (srfi:make-condition-type 'type
				       (srfi-ify-supertype supertype)
				       '(field-key ...)))
	   ;; TODO investigate
	   ;;	   (define-cl-condition-field-accessors field-key . r)
	   ;;	   ...
	   (define-method (make-cl-condition typ . rest*)
	     (if (eq? typ 'type)
		 (apply srfi:make-condition typ
			(cl->srfi-initargs ((field-key . r) ...) rest*))
		 (next-method)))
	   ;; TODO: rest argument
	   )))))

(define warning &warning)
(define-condition style-warning (warning) ())

;; Some mess to figure out later.
#|
(import (system foreign) int)

;; First, define some basic syntax forms.

;; TODO: ignored forms
(define-syntax-rule (in-package ???)
  (begin))

(define-syntax parse-ctype
  (syntax-rules (:int)
    ((_ :int) int)))

(define-syntax defctype (name type docstring)
  (define name (parse-ctype type)))

(define-syntax-rule (defcfun name proc type)
  (define type
    (let ((cfun (dynamic-func name (dynamic-link))))
      (pointer->procedure 
|#