-;;; Guile Emacs Lisp
+;;; Guile Emacs Lisp -*- lexical-binding: t -*-
;;; Copyright (C) 2011 Free Software Foundation, Inc.
(progn ,@body)))
(eval-and-compile
- (defun funcall (function &rest arguments)
- (apply function arguments))
- (defun fset (symbol definition)
- (funcall (@ (language elisp runtime) set-symbol-function!)
- symbol
- definition))
(defun null (object)
(if object nil t))
- (fset 'consp (@ (guile) pair?))
+ (defun consp (object)
+ (%funcall (@ (guile) pair?) object))
(defun listp (object)
(if object (consp object) t))
(defun car (list)
- (if list (funcall (@ (guile) car) list) nil))
+ (if list (%funcall (@ (guile) car) list) nil))
(defun cdr (list)
- (if list (funcall (@ (guile) cdr) list) nil))
- (fset 'make-symbol (@ (guile) make-symbol))
- (defun signal (&rest args)
- (funcall (@ (guile) throw) 'elisp-error args)))
+ (if list (%funcall (@ (guile) cdr) list) nil))
+ (defun make-symbol (name)
+ (%funcall (@ (guile) make-symbol) name))
+ (defun signal (error-symbol data)
+ (%funcall (@ (guile) throw) 'elisp-condition error-symbol data)))
(defmacro lambda (&rest cdr)
`#'(lambda ,@cdr))
(defmacro prog1 (first &rest body)
(let ((temp (make-symbol "prog1-temp")))
- `(lexical-let ((,temp ,first))
+ `(let ((,temp ,first))
+ (declare (lexical ,temp))
,@body
,temp)))
(body (cdr first)))
(if (null body)
(let ((temp (make-symbol "cond-temp")))
- `(lexical-let ((,temp ,condition))
+ `(let ((,temp ,condition))
+ (declare (lexical ,temp))
(if ,temp
,temp
(cond ,@rest))))
(cond ((null conditions) nil)
((null (cdr conditions)) (car conditions))
(t (let ((temp (make-symbol "or-temp")))
- `(lexical-let ((,temp ,(car conditions)))
+ `(let ((,temp ,(car conditions)))
+ (declare (lexical ,temp))
(if ,temp
,temp
(or ,@(cdr conditions))))))))
-(defmacro catch (tag &rest body)
- (let* ((temp (make-symbol "catch-temp"))
- (elisp-key (make-symbol "catch-elisp-key"))
- (key (make-symbol "catch-key"))
- (value (make-symbol "catch-value")))
- `(lexical-let ((,temp ,tag))
- (funcall (@ (guile) catch)
- 'elisp-exception
- #'(lambda () ,@body)
- #'(lambda (,key ,elisp-key ,value)
- (if (eq ,elisp-key ,temp)
- ,value
- (funcall (@ (guile) throw)
- ,key
- ,elisp-key
- ,value)))))))
+(defmacro lexical-let (bindings &rest body)
+ (labels ((loop (list vars)
+ (if (null list)
+ `(let ,bindings
+ (declare (lexical ,@vars))
+ ,@body)
+ (loop (cdr list)
+ (if (consp (car list))
+ `(,(car (car list)) ,@vars)
+ `(,(car list) ,@vars))))))
+ (loop bindings '())))
+
+(defmacro lexical-let* (bindings &rest body)
+ (labels ((loop (list vars)
+ (if (null list)
+ `(let* ,bindings
+ (declare (lexical ,@vars))
+ ,@body)
+ (loop (cdr list)
+ (if (consp (car list))
+ (cons (car (car list)) vars)
+ (cons (car list) vars))))))
+ (loop bindings '())))
+
+(defmacro while (test &rest body)
+ (let ((loop (make-symbol "loop")))
+ `(labels ((,loop ()
+ (if ,test
+ (progn ,@body (,loop))
+ nil)))
+ (,loop))))
(defmacro unwind-protect (bodyform &rest unwindforms)
`(funcall (@ (guile) dynamic-wind)
#'(lambda () ,bodyform)
#'(lambda () ,@unwindforms)))
-(defun throw (tag value)
- (funcall (@ (guile) throw) 'elisp-exception tag value))
+(defun symbolp (object)
+ (%funcall (@ (guile) symbol?) object))
+
+(defun functionp (object)
+ (%funcall (@ (guile) procedure?) object))
+
+(defun symbol-function (symbol)
+ (let ((f (%funcall (@ (language elisp runtime) symbol-function)
+ symbol)))
+ (if (%funcall (@ (language elisp falias) falias?) f)
+ (%funcall (@ (language elisp falias) falias-object) f)
+ f)))
(defun eval (form)
- (funcall (@ (system base compile) compile)
- form
- (funcall (@ (guile) symbol->keyword) 'from)
- 'elisp
- (funcall (@ (guile) symbol->keyword) 'to)
- 'value))
+ (%funcall (@ (system base compile) compile)
+ form
+ (%funcall (@ (guile) symbol->keyword) 'from)
+ 'elisp
+ (%funcall (@ (guile) symbol->keyword) 'to)
+ 'value))
+
+(defun %indirect-function (object)
+ (cond
+ ((functionp object)
+ object)
+ ((symbolp object) ;++ cycle detection
+ (%indirect-function (symbol-function object)))
+ ((listp object)
+ (eval `(function ,object)))
+ (t
+ (signal 'invalid-function `(,object)))))
+
+(defun apply (function &rest arguments)
+ (%funcall (@ (guile) apply)
+ (@ (guile) apply)
+ (%indirect-function function)
+ arguments))
+
+(defun funcall (function &rest arguments)
+ (%funcall (@ (guile) apply)
+ (%indirect-function function)
+ arguments))
+
+(defun fset (symbol definition)
+ (funcall (@ (language elisp runtime) set-symbol-function!)
+ symbol
+ (if (functionp definition)
+ definition
+ (funcall (@ (language elisp falias) make-falias)
+ #'(lambda (&rest args) (apply definition args))
+ definition)))
+ definition)
(defun load (file)
(funcall (@ (system base compile) compile-file)
;;; Equality predicates
-(fset 'eq (@ (guile) eq?))
-(fset 'equal (@ (guile) equal?))
+(defun eq (obj1 obj2)
+ (if obj1
+ (funcall (@ (guile) eq?) obj1 obj2)
+ (null obj2)))
+
+(defun eql (obj1 obj2)
+ (if obj1
+ (funcall (@ (guile) eqv?) obj1 obj2)
+ (null obj2)))
+
+(defun equal (obj1 obj2)
+ (if obj1
+ (funcall (@ (guile) equal?) obj1 obj2)
+ (null obj2)))
;;; Symbols
-(fset 'symbolp (@ (guile) symbol?))
+;;; `symbolp' and `symbol-function' are defined above.
+
(fset 'symbol-value (@ (language elisp runtime) symbol-value))
-(fset 'symbol-function (@ (language elisp runtime) symbol-function))
(fset 'set (@ (language elisp runtime) set-symbol-value!))
(fset 'makunbound (@ (language elisp runtime) makunbound!))
(fset 'fmakunbound (@ (language elisp runtime) fmakunbound!))
(defun nth (n list)
(car (nthcdr n list)))
+(defun %member (elt list test)
+ (cond
+ ((null list) nil)
+ ((consp list)
+ (if (funcall test elt (car list))
+ list
+ (%member elt (cdr list) test)))
+ (t (signal 'wrong-type-argument `(listp ,list)))))
+
+(defun member (elt list)
+ (%member elt list #'equal))
+
+(defun memql (elt list)
+ (%member elt list #'eql))
+
+(defun memq (elt list)
+ (%member elt list #'eq))
+
;;; Strings
(defun string (&rest characters)
;;; Property lists
(defun %plist-member (plist property test)
- (catch 'loop
- (while plist
- (if (funcall test (car plist) property)
- (throw 'loop (cdr plist))
- (setq plist (cddr plist))))))
+ (cond
+ ((null plist) nil)
+ ((consp plist)
+ (if (funcall test (car plist) property)
+ (cdr plist)
+ (%plist-member (cdr (cdr plist)) property test)))
+ (t (signal 'wrong-type-argument `(listp ,plist)))))
(defun %plist-get (plist property test)
(car (%plist-member plist property test)))
(defun %plist-put (plist property value test)
- (lexical-let ((x (%plist-member plist property test)))
+ (let ((x (%plist-member plist property test)))
(if x
(progn (setcar x value) plist)
(cons property (cons value plist)))))
(defun put (symbol propname value)
(setplist symbol (plist-put (symbol-plist symbol) propname value)))
+
+;;; Nonlocal exits
+
+(defmacro condition-case (var bodyform &rest handlers)
+ (let ((key (make-symbol "key"))
+ (error-symbol (make-symbol "error-symbol"))
+ (data (make-symbol "data"))
+ (conditions (make-symbol "conditions")))
+ (flet ((handler->cond-clause (handler)
+ `((or ,@(mapcar #'(lambda (c) `(memq ',c ,conditions))
+ (if (consp (car handler))
+ (car handler)
+ (list (car handler)))))
+ ,@(cdr handler))))
+ `(funcall (@ (guile) catch)
+ 'elisp-condition
+ #'(lambda () ,bodyform)
+ #'(lambda (,key ,error-symbol ,data)
+ (declare (lexical ,key ,error-symbol ,data))
+ (let ((,conditions
+ (get ,error-symbol 'error-conditions))
+ ,@(if var
+ `((,var (cons ,error-symbol ,data)))
+ '()))
+ (declare (lexical ,conditions
+ ,@(if var `(,var) '())))
+ (cond ,@(mapcar #'handler->cond-clause handlers)
+ (t (signal ,error-symbol ,data)))))))))
+
+(put 'error 'error-conditions '(error))
+(put 'wrong-type-argument 'error-conditions '(wrong-type-argument error))
+(put 'invalid-function 'error-conditions '(invalid-function error))
+(put 'no-catch 'error-conditions '(no-catch error))
+(put 'throw 'error-conditions '(throw))
+
+(defvar %catch nil)
+
+(defmacro catch (tag &rest body)
+ (let ((tag-value (make-symbol "tag-value"))
+ (c (make-symbol "c"))
+ (data (make-symbol "data")))
+ `(let ((,tag-value ,tag))
+ (declare (lexical ,tag-value))
+ (condition-case ,c
+ (let ((%catch t))
+ ,@body)
+ (throw
+ (let ((,data (cdr ,c)))
+ (declare (lexical ,data))
+ (if (eq (car ,data) ,tag-value)
+ (car (cdr ,data))
+ (apply #'throw ,data))))))))
+
+(defun throw (tag value)
+ (signal (if %catch 'throw 'no-catch) (list tag value)))
+
+;;; I/O
+
+(defun princ (object)
+ (funcall (@ (guile) display) object))
+
+(defun print (object)
+ (funcall (@ (guile) write) object))
+
+(defun terpri ()
+ (funcall (@ (guile) newline)))
+
+(defun format* (stream string &rest args)
+ (apply (@ (guile) format) stream string args))
HCoop / bpt / guile.git / blobdiff