From fc45b7e8e826d2e870f6e316749f87c20d083cb1 Mon Sep 17 00:00:00 2001 From: BT Templeton Date: Wed, 7 Mar 2012 14:34:13 -0500 Subject: [PATCH 1/6] integerp, wholenump return nil for non-numbers * module/language/elisp/boot.el (integerp, wholenump): Call `integer?' before `exact?' so that these predicates return nil for non-numbers instead of signalling an error. --- module/language/elisp/boot.el | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/module/language/elisp/boot.el b/module/language/elisp/boot.el index bec32b545..1ea86397f 100644 --- a/module/language/elisp/boot.el +++ b/module/language/elisp/boot.el @@ -237,16 +237,14 @@ (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)) From 12c00a0453bd877030509bba93cf6113dc4c468d Mon Sep 17 00:00:00 2001 From: BT Templeton Date: Wed, 7 Mar 2012 20:04:46 -0500 Subject: [PATCH 2/6] elisp sequence functions * module/language/elisp/boot.el (nreverse, assoc, assq, rplaca, rplacd) (caar, cadr, cdar, cddr, dolist, stringp, string-equal, string=) (substring, upcase, downcase, string-match, make-vector, mapc, aref) (aset, concat): New functions. --- module/language/elisp/boot.el | 82 +++++++++++++++++++++++++++++++++++ 1 file changed, 82 insertions(+) diff --git a/module/language/elisp/boot.el b/module/language/elisp/boot.el index 1ea86397f..29c2e96d5 100644 --- a/module/language/elisp/boot.el +++ b/module/language/elisp/boot.el @@ -308,6 +308,7 @@ (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) @@ -361,12 +362,79 @@ (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) + `(mapc #'(lambda (,var) + ,@body + ,result) + ,list)) + spec)) + ;;; Strings (defun string (&rest characters) (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)) @@ -374,6 +442,20 @@ (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) From c0652730bcbb769c732fbc459f5852077fded5c6 Mon Sep 17 00:00:00 2001 From: BT Templeton Date: Wed, 7 Mar 2012 20:05:16 -0500 Subject: [PATCH 3/6] elisp: when, unless * module/language/elisp/boot.el (when, unless): New macros. --- module/language/elisp/boot.el | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/module/language/elisp/boot.el b/module/language/elisp/boot.el index 29c2e96d5..2abd26e38 100644 --- a/module/language/elisp/boot.el +++ b/module/language/elisp/boot.el @@ -131,6 +131,14 @@ #'(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)) From 5c65ee510f98940397b9d69d4020f588ec9f95a8 Mon Sep 17 00:00:00 2001 From: BT Templeton Date: Wed, 7 Mar 2012 20:06:54 -0500 Subject: [PATCH 4/6] elisp: symbol-name, intern * module/language/elisp/boot.el (symbol-name, intern): New functions. --- module/language/elisp/boot.el | 2 ++ 1 file changed, 2 insertions(+) diff --git a/module/language/elisp/boot.el b/module/language/elisp/boot.el index 2abd26e38..0b2fc88fb 100644 --- a/module/language/elisp/boot.el +++ b/module/language/elisp/boot.el @@ -222,12 +222,14 @@ ;;; `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) From 43ff6804d64f4db680961849a12decd34e571416 Mon Sep 17 00:00:00 2001 From: BT Templeton Date: Wed, 7 Mar 2012 20:08:46 -0500 Subject: [PATCH 5/6] elisp i/o * module/language/elisp/boot.el (send-string-to-terminal) (read-from-minibuffer, prin1-to-string): New functions. --- module/language/elisp/boot.el | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/module/language/elisp/boot.el b/module/language/elisp/boot.el index 0b2fc88fb..adafe4d29 100644 --- a/module/language/elisp/boot.el +++ b/module/language/elisp/boot.el @@ -583,3 +583,16 @@ (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)) From 52d2472441891cbb85ec23d16e685d91c5ed8bfd Mon Sep 17 00:00:00 2001 From: BT Templeton Date: Wed, 7 Mar 2012 20:09:21 -0500 Subject: [PATCH 6/6] elisp rng * module/language/elisp/boot.el (random): New function. --- module/language/elisp/boot.el | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/module/language/elisp/boot.el b/module/language/elisp/boot.el index adafe4d29..53711e1f6 100644 --- a/module/language/elisp/boot.el +++ b/module/language/elisp/boot.el @@ -596,3 +596,18 @@ (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))