(defmacro @ (module symbol)
`(guile-ref ,module ,symbol))
+(defmacro @@ (module symbol)
+ `(guile-private-ref ,module ,symbol))
+
+(defmacro defun (name args &rest body)
+ `(let ((proc (function (lambda ,args ,@body))))
+ (%funcall (@ (language elisp runtime) set-symbol-function!)
+ ',name
+ proc)
+ (%funcall (@ (guile) set-procedure-property!)
+ proc 'name ',name)
+ ',name))
+
+(defun omega () (omega))
+
(defmacro eval-and-compile (&rest body)
`(progn
(eval-when-compile ,@body)
(progn ,@body)))
+(defmacro %define-compiler-macro (name args &rest body)
+ `(eval-and-compile
+ (%funcall
+ (@ (language elisp runtime) set-symbol-plist!)
+ ',name
+ (%funcall
+ (@ (guile) cons*)
+ '%compiler-macro
+ #'(lambda ,args ,@body)
+ (%funcall (@ (language elisp runtime) symbol-plist) ',name)))
+ ',name))
+
+(defmacro defsubst (name args &rest body)
+ `(progn
+ (defun ,name ,args ,@body)
+ (eval-and-compile
+ (%define-compiler-macro ,name (form)
+ (%funcall (@ (guile) cons*)
+ '%funcall
+ (%funcall
+ (@ (guile) list)
+ 'function
+ (%funcall (@ (guile) cons*) 'lambda ',args ',body))
+ (%funcall (@ (guile) cdr) form))))))
+
+(eval-and-compile
+ (defun eval (form)
+ (%funcall (@ (language elisp runtime) eval-elisp) form)))
+
(eval-and-compile
- (defun null (object)
+ (defsubst null (object)
+ (declare (lexical object))
(if object nil t))
- (defun consp (object)
- (%funcall (@ (guile) pair?) object))
+ (defsubst consp (x)
+ (declare (lexical x))
+ (%funcall (@ (guile) pair?) x))
+ (defsubst atom (x)
+ (declare (lexical x))
+ (null (consp x)))
(defun listp (object)
+ (declare (lexical object))
(if object (consp object) t))
- (defun car (list)
+ (defsubst car (list)
+ (declare (lexical list))
(if list (%funcall (@ (guile) car) list) nil))
- (defun cdr (list)
+ (defsubst cdr (list)
+ (declare (lexical list))
(if list (%funcall (@ (guile) cdr) list) nil))
(defun make-symbol (name)
(%funcall (@ (guile) make-symbol) name))
- (defun signal (&rest args)
- (%funcall (@ (guile) throw) 'elisp-error args)))
+ (defun gensym ()
+ (%funcall (@ (guile) gensym)))
+ (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 (gensym)))
+ `(let ((,temp ,first))
+ (declare (lexical ,temp))
,@body
,temp)))
+(defun interactive (&optional arg)
+ nil)
+
(defmacro prog2 (form1 form2 &rest body)
`(progn ,form1 (prog1 ,form2 ,@body)))
(let ((condition (car first))
(body (cdr first)))
(if (null body)
- (let ((temp (make-symbol "cond-temp")))
- `(lexical-let ((,temp ,condition))
+ (let ((temp (gensym)))
+ `(let ((,temp ,condition))
+ (declare (lexical ,temp))
(if ,temp
,temp
(cond ,@rest))))
(defmacro or (&rest conditions)
(cond ((null conditions) nil)
((null (cdr conditions)) (car conditions))
- (t (let ((temp (make-symbol "or-temp")))
- `(lexical-let ((,temp ,(car conditions)))
+ (t (let ((temp (gensym)))
+ `(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 (gensym)))
+ `(labels ((,loop ()
+ (if ,test
+ (progn ,@body (,loop))
+ nil)))
+ (,loop))))
(defmacro unwind-protect (bodyform &rest unwindforms)
- `(funcall (@ (guile) dynamic-wind)
- #'(lambda () nil)
- #'(lambda () ,bodyform)
- #'(lambda () ,@unwindforms)))
+ `(%funcall (@ (guile) dynamic-wind)
+ #'(lambda () nil)
+ #'(lambda () ,bodyform)
+ #'(lambda () ,@unwindforms)))
+
+(defmacro when (cond &rest body)
+ `(if ,cond
+ (progn ,@body)))
+
+(defmacro unless (cond &rest body)
+ `(when (not ,cond)
+ ,@body))
(defun symbolp (object)
(%funcall (@ (guile) symbol?) object))
-(defun functionp (object)
+(defun %functionp (object)
(%funcall (@ (guile) procedure?) object))
(defun symbol-function (symbol)
(defun %indirect-function (object)
(cond
- ((functionp object)
+ ((%functionp object)
object)
+ ((null object)
+ (signal 'void-function nil))
((symbolp object) ;++ cycle detection
- (%indirect-function (symbol-function object)))
+ (%indirect-function
+ (%funcall (@ (language elisp runtime) symbol-function) object)))
((listp object)
(eval `(function ,object)))
(t
(%indirect-function function)
arguments))
+(defun autoload-do-load (fundef &optional funname macro-only)
+ (and (load (cadr fundef))
+ (%indirect-function funname)))
+
+(defun fset (symbol definition)
+ (funcall (@ (language elisp runtime) set-symbol-function!)
+ symbol
+ definition))
+
+(defun eq (obj1 obj2)
+ (if obj1
+ (%funcall (@ (guile) eq?) obj1 obj2)
+ (if obj2 nil t)))
+
+(defun nthcdr (n list)
+ (let ((i 0))
+ (while (< i n)
+ (setq list (cdr list)
+ i (+ i 1)))
+ list))
+
+(defun nth (n list)
+ (car (nthcdr n list)))
+
(defun fset (symbol definition)
(funcall (@ (language elisp runtime) set-symbol-function!)
symbol
- (if (functionp definition)
- definition
+ (cond
+ ((%funcall (@ (guile) procedure?) definition)
+ definition)
+ ((and (consp definition)
+ (eq (car definition) 'macro))
+ (if (%funcall (@ (guile) procedure?) (cdr definition))
+ definition
+ (cons 'macro
+ (funcall (@ (language elisp falias) make-falias)
+ (function
+ (lambda (&rest args) (apply (cdr definition) args)))
+ (cdr definition)))))
+ ((and (consp definition)
+ (eq (car definition) 'autoload))
+ (if (or (eq (nth 4 definition) 'macro)
+ (eq (nth 4 definition) t))
+ (cons 'macro
+ (funcall
+ (@ (language elisp falias) make-falias)
+ (function (lambda (&rest args)
+ (apply (cdr (autoload-do-load definition symbol nil)) args)))
+ definition))
+ (funcall
+ (@ (language elisp falias) make-falias)
+ (function (lambda (&rest args)
+ (apply (autoload-do-load definition symbol nil) args)))
+ definition)))
+ (t
(funcall (@ (language elisp falias) make-falias)
- #'(lambda (&rest args) (apply definition args))
- definition)))
+ (function (lambda (&rest args) (apply definition args)))
+ definition))))
definition)
-(defun throw (tag value)
- (funcall (@ (guile) throw) 'elisp-exception tag value))
-
-(defun load (file)
+(defun gload (file)
(funcall (@ (system base compile) compile-file)
file
(funcall (@ (guile) symbol->keyword) 'from)
;;; Equality predicates
-(defun eq (obj1 obj2)
- (if obj1
- (funcall (@ (guile) eq?) obj1 obj2)
- (null obj2)))
-
(defun eql (obj1 obj2)
(if obj1
(funcall (@ (guile) eqv?) obj1 obj2)
;;; `symbolp' and `symbol-function' are defined above.
+(fset 'symbol-name (@ (guile) symbol->string))
(fset 'symbol-value (@ (language elisp runtime) symbol-value))
(fset 'set (@ (language elisp runtime) set-symbol-value!))
(fset 'makunbound (@ (language elisp runtime) makunbound!))
(fset 'fmakunbound (@ (language elisp runtime) fmakunbound!))
(fset 'boundp (@ (language elisp runtime) symbol-bound?))
(fset 'fboundp (@ (language elisp runtime) symbol-fbound?))
+(fset 'intern (@ (guile) string->symbol))
-(defun defvaralias (new-alias base-variable &optional docstring)
- (let ((fluid (funcall (@ (language elisp runtime) symbol-fluid)
- base-variable)))
- (funcall (@ (language elisp runtime) set-symbol-fluid!)
- new-alias
- fluid)
- base-variable))
+;(defun defvaralias (new-alias base-variable &optional docstring)
+; (let ((fluid (funcall (@ (language elisp runtime) symbol-fluid)
+; base-variable)))
+; (funcall (@ (language elisp runtime) set-symbol-fluid!)
+; new-alias
+; fluid)
+; base-variable))
;;; Numerical type predicates
(null (funcall (@ (guile) integer?) object)))))
(defun integerp (object)
- (and (funcall (@ (guile) exact?) object)
- (funcall (@ (guile) integer?) object)))
+ (and (funcall (@ (guile) integer?) object)
+ (funcall (@ (guile) exact?) object)))
(defun numberp (object)
(funcall (@ (guile) real?) object))
(defun wholenump (object)
- (and (funcall (@ (guile) exact?) object)
- (funcall (@ (guile) integer?) object)
- (>= object 0)))
+ (and (integerp object) (>= object 0)))
(defun zerop (object)
(= object 0))
(fset 'make-list (@ (guile) make-list))
(fset 'append (@ (guile) append))
(fset 'reverse (@ (guile) reverse))
+(fset 'nreverse (@ (guile) reverse!))
(defun car-safe (object)
(if (consp object)
newcdr)
(signal 'wrong-type-argument `(consp ,cell))))
-(defun nthcdr (n list)
- (let ((i 0))
- (while (< i n)
- (setq list (cdr list)
- i (+ i 1)))
- 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 nth (n list)
- (car (nthcdr n 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))
+
+(defun assoc (key list)
+ (funcall (@ (srfi srfi-1) assoc) key list #'equal))
+
+(defun assq (key list)
+ (funcall (@ (srfi srfi-1) assoc) key list #'eq))
+
+(defun rplaca (cell newcar)
+ (funcall (@ (guile) set-car!) cell newcar)
+ newcar)
+
+(defun rplacd (cell newcdr)
+ (funcall (@ (guile) set-cdr!) cell newcdr)
+ newcdr)
+
+(defun caar (x)
+ (car (car x)))
+
+(defun cadr (x)
+ (car (cdr x)))
+
+(defun cdar (x)
+ (cdr (car x)))
+
+(defun cddr (x)
+ (cdr (cdr x)))
+
+(defmacro dolist (spec &rest body)
+ (apply #'(lambda (var list &optional result)
+ (list 'progn
+ (list 'mapc
+ (cons 'lambda (cons (list var) body))
+ list)
+ result))
+ spec))
;;; Strings
(funcall (@ (guile) list->string)
(mapcar (@ (guile) integer->char) characters)))
+(defun stringp (object)
+ (funcall (@ (guile) string?) object))
+
+(defun string-equal (s1 s2)
+ (let ((s1 (if (symbolp s1) (symbol-name s1) s1))
+ (s2 (if (symbolp s2) (symbol-name s2) s2)))
+ (funcall (@ (guile) string=?) s1 s2)))
+
+(fset 'string= 'string-equal)
+
+(defun substring (string from &optional to)
+ (apply (@ (guile) substring) string from (if to (list to) nil)))
+
+(defun upcase (obj)
+ (funcall (@ (guile) string-upcase) obj))
+
+(defun downcase (obj)
+ (funcall (@ (guile) string-downcase) obj))
+
+(defun string-match (regexp string &optional start)
+ (let ((m (funcall (@ (ice-9 regex) string-match)
+ regexp
+ string
+ (or start 0))))
+ (if m
+ (funcall (@ (ice-9 regex) match:start) m 0)
+ nil)))
+
+;; Vectors
+
+(defun make-vector (length init)
+ (funcall (@ (guile) make-vector) length init))
+
;;; Sequences
-(fset 'length (@ (guile) length))
+(defun length (sequence)
+ (funcall (if (listp sequence)
+ (@ (guile) length)
+ (@ (guile) generalized-vector-length))
+ sequence))
(defun mapcar (function sequence)
(funcall (@ (guile) map) function sequence))
+(defun mapc (function sequence)
+ (funcall (@ (guile) for-each) function sequence)
+ sequence)
+
+(defun aref (array idx)
+ (funcall (@ (guile) generalized-vector-ref) array idx))
+
+(defun aset (array idx newelt)
+ (funcall (@ (guile) generalized-vector-set!) array idx newelt)
+ newelt)
+
+(defun concat (&rest sequences)
+ (apply (@ (guile) string-append) sequences))
+
;;; 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 prin1 (object)
+ (funcall (@ (guile) write) object))
+
+(defun terpri ()
+ (funcall (@ (guile) newline)))
+
+(defun format* (stream string &rest args)
+ (apply (@ (guile) format) stream string args))
+
+(defun send-string-to-terminal (string)
+ (princ string))
+
+(defun read-from-minibuffer (prompt &rest ignore)
+ (princ prompt)
+ (let ((value (funcall (@ (ice-9 rdelim) read-line))))
+ (if (funcall (@ (guile) eof-object?) value)
+ ""
+ value)))
+
+(defun prin1-to-string (object)
+ (format* nil "~S" object))
+
+;; Random number generation
+
+(defvar %random-state (funcall (@ (guile) copy-random-state)
+ (@ (guile) *random-state*)))
+
+(defun random (&optional limit)
+ (if (eq limit t)
+ (setq %random-state
+ (funcall (@ (guile) random-state-from-platform))))
+ (funcall (@ (guile) random)
+ (if (wholenump limit)
+ limit
+ (@ (guile) most-positive-fixnum))
+ %random-state))
+
+(defmacro save-excursion (&rest body)
+ `(call-with-save-excursion #'(lambda () ,@body)))
+
+(defmacro save-current-buffer (&rest body)
+ `(call-with-save-current-buffer #'(lambda () ,@body)))
+
+(defmacro save-restriction (&rest body)
+ `(call-with-save-restriction #'(lambda () ,@body)))
+
+(defmacro track-mouse (&rest body)
+ `(call-with-track-mouse #'(lambda () ,@body)))
+
+(defmacro setq-default (var value &rest args)
+ `(progn (set-default ',var ,value)
+ ,(if (null args)
+ var
+ `(setq-default ,@args))))
+
+(defmacro catch (tag &rest body)
+ `(call-with-catch ,tag #'(lambda () ,@body)))
+
+(defmacro condition-case (var bodyform &rest args)
+ (if (consp args)
+ (let* ((handler (car args))
+ (handlers (cdr args))
+ (handler-conditions (car handler))
+ (handler-body (cdr handler)))
+ `(call-with-handler ',var
+ ',handler-conditions
+ #'(lambda () ,@handler-body)
+ #'(lambda ()
+ (condition-case ,var
+ ,bodyform
+ ,@handlers))))
+ bodyform))
+
+(defun backtrace-frame (nframes)
+ (let* ((stack (funcall (@ (guile) make-stack) t))
+ (frame (stack-ref stack nframes))
+ (proc (funcall (@ (guile) frame-procedure) frame))
+ (pname (or (and (%functionp proc)
+ (funcall (@ (guile) procedure-name) proc))
+ proc))
+ (args (funcall (@ (guile) frame-arguments) frame)))
+ (cons t (cons pname args))))
+
+(defun backtrace ()
+ (interactive)
+ (let* ((stack (funcall (@ (guile) make-stack) t))
+ (frame (funcall (@ (guile) stack-ref) stack 1))
+ (space (funcall (@ (guile) integer->char) 32)))
+ (while frame
+ (princ (string 32 32))
+ (let ((proc (funcall (@ (guile) frame-procedure) frame)))
+ (prin1 (or (and (%functionp proc)
+ (funcall (@ (guile) procedure-name) proc))
+ proc)))
+ (prin1 (funcall (@ (guile) frame-arguments) frame))
+ (terpri)
+ (setq frame (funcall (@ (guile) frame-previous) frame)))
+ nil))
+
+(defun %set-eager-macroexpansion-mode (ignore)
+ nil)
HCoop / bpt / guile.git / blobdiff