(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)))
+(eval-and-compile
+ (defun eval (form)
+ (%funcall (@ (language elisp runtime) eval-elisp) form)))
+
(eval-and-compile
(defun null (object)
(if object nil t))
(if list (%funcall (@ (guile) cdr) list) nil))
(defun make-symbol (name)
(%funcall (@ (guile) make-symbol) name))
+ (defun gensym ()
+ (%funcall (@ (guile) gensym)))
(defun signal (error-symbol data)
(%funcall (@ (guile) throw) 'elisp-condition error-symbol data)))
`#'(lambda ,@cdr))
(defmacro prog1 (first &rest body)
- (let ((temp (make-symbol "prog1-temp")))
+ (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")))
+ (let ((temp (gensym)))
`(let ((,temp ,condition))
(declare (lexical ,temp))
(if ,temp
(defmacro or (&rest conditions)
(cond ((null conditions) nil)
((null (cdr conditions)) (car conditions))
- (t (let ((temp (make-symbol "or-temp")))
+ (t (let ((temp (gensym)))
`(let ((,temp ,(car conditions)))
(declare (lexical ,temp))
(if ,temp
(loop bindings '())))
(defmacro while (test &rest body)
- (let ((loop (make-symbol "loop")))
+ (let ((loop (gensym)))
`(labels ((,loop ()
(if ,test
(progn ,@body (,loop))
(,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
(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
- (if (functionp definition)
- definition
+ 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
+ (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 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)
(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
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 nth (n list)
- (car (nthcdr n list)))
-
(defun %member (elt list test)
(cond
((null list) nil)
(defmacro dolist (spec &rest body)
(apply #'(lambda (var list &optional result)
- `(mapc #'(lambda (,var)
- ,@body
- ,result)
- ,list))
+ (list 'progn
+ (list 'mapc
+ (cons 'lambda (cons (list var) body))
+ list)
+ result))
spec))
;;; Strings
(defun print (object)
(funcall (@ (guile) write) object))
+(defun prin1 (object)
+ (funcall (@ (guile) write) object))
+
(defun terpri ()
(funcall (@ (guile) newline)))
(@ (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))
+ (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