(%compile-defvar ',name))
(setq ,name ,value)))
- (defmacro defvar (name value)
+ (defmacro defvar (name &optional value)
`(%defvar ,name ,value))
(defmacro %defun (name args &rest body)
(defun find-symbol (name)
(get *package* name))
- (defmacro when (condition &rest body)
- `(if ,condition (progn ,@body) nil))
-
- (defmacro unless (condition &rest body)
- `(if ,condition nil (progn ,@body)))
-
- (defmacro dolist (iter &rest body)
- (let ((var (first iter))
- (g!list (make-symbol "LIST")))
- `(let ((,g!list ,(second iter))
- (,var nil))
- (while ,g!list
- (setq ,var (car ,g!list))
- ,@body
- (setq ,g!list (cdr ,g!list))))))
-
+ ;; Basic functions
(defun = (x y) (= x y))
(defun + (x y) (+ x y))
(defun - (x y) (- x y))
(defun 1+ (x) (+ x 1))
(defun 1- (x) (- x 1))
(defun zerop (x) (= x 0))
- (defun not (x) (if x nil t))
-
(defun truncate (x y) (floor (/ x y)))
+ (defun eql (x y) (eq x y))
+
+ (defun not (x) (if x nil t))
+
(defun cons (x y ) (cons x y))
(defun consp (x) (consp x))
-
(defun car (x) (car x))
(defun cdr (x) (cdr x))
-
(defun caar (x) (car (car x)))
(defun cadr (x) (car (cdr x)))
(defun cdar (x) (cdr (car x)))
(defun caddr (x) (car (cdr (cdr x))))
(defun cdddr (x) (cdr (cdr (cdr x))))
(defun cadddr (x) (car (cdr (cdr (cdr x)))))
-
(defun first (x) (car x))
(defun second (x) (cadr x))
(defun third (x) (caddr x))
(defun fourth (x) (cadddr x))
- (defun list (&rest args)
- args)
-
+ (defun list (&rest args) args)
(defun atom (x)
- (not (consp x))))
+ (not (consp x)))
+
+ ;; Basic macros
+
+ (defmacro incf (x &optional (delta 1))
+ `(setq ,x (+ ,x ,delta)))
+
+ (defmacro decf (x &optional (delta 1))
+ `(setq ,x (- ,x ,delta)))
+
+ (defmacro push (x place)
+ `(setq ,place (cons ,x ,place)))
+
+ (defmacro when (condition &rest body)
+ `(if ,condition (progn ,@body) nil))
+ (defmacro unless (condition &rest body)
+ `(if ,condition nil (progn ,@body)))
+
+ (defmacro dolist (iter &rest body)
+ (let ((var (first iter))
+ (g!list (make-symbol "LIST")))
+ `(let ((,g!list ,(second iter))
+ (,var nil))
+ (while ,g!list
+ (setq ,var (car ,g!list))
+ ,@body
+ (setq ,g!list (cdr ,g!list))))))
+
+ (defmacro cond (&rest clausules)
+ (if (null clausules)
+ nil
+ (if (eq (caar clausules) t)
+ `(progn ,@(cdar clausules))
+ `(if ,(caar clausules)
+ (progn ,@(cdar clausules))
+ (cond ,@(cdr clausules))))))
+
+ (defmacro case (form &rest clausules)
+ (let ((!form (make-symbol "FORM")))
+ `(let ((,!form ,form))
+ (cond
+ ,@(mapcar (lambda (clausule)
+ (if (eq (car clausule) t)
+ clausule
+ `((eql ,!form ,(car clausule))
+ ,@(cdr clausule))))
+ clausules)))))
+
+ (defmacro ecase (form &rest clausules)
+ `(case ,form
+ ,@(append
+ clausules
+ `((t
+ (error "ECASE expression failed."))))))
+
+ (defmacro and (&rest forms)
+ (cond
+ ((null forms)
+ t)
+ ((null (cdr forms))
+ (car forms))
+ (t
+ `(if ,(car forms)
+ (and ,@(cdr forms))
+ nil))))
+
+ (defmacro or (&rest forms)
+ (cond
+ ((null forms)
+ nil)
+ ((null (cdr forms))
+ (car forms))
+ (t
+ (let ((g (make-symbol "VAR")))
+ `(let ((,g ,(car forms)))
+ (if ,g ,g (or ,@(cdr forms))))))))
+
+ (defmacro prog1 (form &rest body)
+ (let ((value (make-symbol "VALUE")))
+ `(let ((,value ,form))
+ ,@body
+ ,value))))
+
+;;; This couple of helper functions will be defined in both Common
+;;; Lisp and in Lispstrack.
(defun ensure-list (x)
(if (listp x)
x
(cdr list)
(funcall func initial (car list)))))
+;;; Go on growing the Lisp language in Lispstrack, with more high
+;;; level utilities as well as correct versions of other
+;;; constructions.
#+lispstrack
(progn
(defmacro defun (name args &rest body)
(%defun ,name ,args ,@body)
',name))
- (defmacro defvar (name value)
+ (defmacro defvar (name &optional value)
`(progn
(%defvar ,name ,value)
',name))
(defun reverse (list)
(reverse-aux list '()))
- (defmacro incf (x)
- `(setq ,x (1+ ,x)))
-
- (defmacro decf (x)
- `(setq ,x (1- ,x)))
-
(defun list-length (list)
(let ((l 0))
(while (not (null list))
(cons (funcall func (car list))
(mapcar func (cdr list)))))
- (defmacro push (x place)
- `(setq ,place (cons ,x ,place)))
-
- (defmacro cond (&rest clausules)
- (if (null clausules)
- nil
- (if (eq (caar clausules) t)
- `(progn ,@(cdar clausules))
- `(if ,(caar clausules)
- (progn ,@(cdar clausules))
- (cond ,@(cdr clausules))))))
-
- (defmacro case (form &rest clausules)
- (let ((!form (make-symbol "FORM")))
- `(let ((,!form ,form))
- (cond
- ,@(mapcar (lambda (clausule)
- (if (eq (car clausule) t)
- clausule
- `((eql ,!form ,(car clausule))
- ,@(cdr clausule))))
- clausules)))))
-
- (defmacro ecase (form &rest clausules)
- `(case ,form
- ,@(append
- clausules
- `((t
- (error "ECASE expression failed."))))))
-
(defun code-char (x) x)
(defun char-code (x) x)
(defun char= (x y) (= x y))
- (defmacro and (&rest forms)
- (cond
- ((null forms)
- t)
- ((null (cdr forms))
- (car forms))
- (t
- `(if ,(car forms)
- (and ,@(cdr forms))
- nil))))
-
- (defmacro or (&rest forms)
- (cond
- ((null forms)
- nil)
- ((null (cdr forms))
- (car forms))
- (t
- (let ((g (make-symbol "VAR")))
- `(let ((,g ,(car forms)))
- (if ,g ,g (or ,@(cdr forms))))))))
-
- (defmacro prog1 (form &rest body)
- (let ((value (make-symbol "VALUE")))
- `(let ((,value ,form))
- ,@body
- ,value)))
-
(defun <= (x y) (or (< x y) (= x y)))
(defun >= (x y) (not (< x y)))
+ (defun integerp (x)
+ (and (numberp x) (= (floor x) x)))
+
(defun plusp (x) (< 0 x))
(defun minusp (x) (< x 0))
((zerop n) (car list))
(t (nth (1- n) (cdr list)))))
- (defun integerp (x)
- (and (numberp x) (= (floor x) x)))
-
(defun last (x)
- (if (null (cdr x))
- x
- (last (cdr x))))
+ (if (consp (cdr x))
+ (last (cdr x))
+ x))
(defun butlast (x)
- (if (null (cdr x))
- nil
- (cons (car x) (butlast (cdr x)))))
+ (and (consp (cdr x))
+ (cons (car x) (butlast (cdr x)))))
(defun member (x list)
(cond
(- x #\0)
nil))
+ (defun subseq (seq a &optional b)
+ (cond
+ ((stringp seq)
+ (if b
+ (slice seq a b)
+ (slice seq a)))
+ (t
+ (error "Unsupported argument."))))
+
(defun parse-integer (string)
(let ((value 0)
(index 0)
(incf index))
ret))
- (defun eql (x y)
- (eq x y))
-
(defun assoc (x alist)
(cond
((null alist)
(!reduce #'concat-two strs ""))
;;; Concatenate a list of strings, with a separator
-(defun join (list separator)
+(defun join (list &optional (separator ""))
(cond
((null list)
"")
separator
(join (cdr list) separator)))))
-(defun join-trailing (list separator)
+(defun join-trailing (list &optional (separator ""))
(if (null list)
""
(concat (car list) separator (join-trailing (cdr list) separator))))
(defun integer-to-string (x)
- (if (zerop x)
- "0"
- (let ((digits nil))
- (while (not (zerop x))
- (push (mod x 10) digits)
- (setq x (truncate x 10)))
- (join (mapcar (lambda (d) (string (char "0123456789" d)))
- digits)
- ""))))
+ (cond
+ ((zerop x)
+ "0")
+ ((minusp x)
+ (concat "-" (integer-to-string (- 0 x))))
+ (t
+ (let ((digits nil))
+ (while (not (zerop x))
+ (push (mod x 10) digits)
+ (setq x (truncate x 10)))
+ (join (mapcar (lambda (d) (string (char "0123456789" d)))
+ digits))))))
(defun print-to-string (form)
(cond
(setq ch (%read-char stream)))
string))
+(defun read-sharp (stream)
+ (%read-char stream)
+ (ecase (%read-char stream)
+ (#\'
+ (list 'function (ls-read stream)))
+ (#\\
+ (let ((cname
+ (concat (string (%read-char stream))
+ (read-until stream #'terminalp))))
+ (cond
+ ((string= cname "space") (char-code #\space))
+ ((string= cname "tab") (char-code #\tab))
+ ((string= cname "newline") (char-code #\newline))
+ (t (char-code (char cname 0))))))
+ (#\+
+ (let ((feature (read-until stream #'terminalp)))
+ (cond
+ ((string= feature "common-lisp")
+ (ls-read stream) ;ignore
+ (ls-read stream))
+ ((string= feature "lispstrack")
+ (ls-read stream))
+ (t
+ (error "Unknown reader form.")))))))
+
(defvar *eof* (make-symbol "EOF"))
(defun ls-read (stream)
(skip-whitespaces-and-comments stream)
(progn (%read-char stream) (list 'unquote-splicing (ls-read stream)))
(list 'unquote (ls-read stream))))
((char= ch #\#)
- (%read-char stream)
- (ecase (%read-char stream)
- (#\'
- (list 'function (ls-read stream)))
- (#\\
- (let ((cname
- (concat (string (%read-char stream))
- (read-until stream #'terminalp))))
- (cond
- ((string= cname "space") (char-code #\space))
- ((string= cname "tab") (char-code #\tab))
- ((string= cname "newline") (char-code #\newline))
- (t (char-code (char cname 0))))))
- (#\+
- (let ((feature (read-until stream #'terminalp)))
- (cond
- ((string= feature "common-lisp")
- (ls-read stream) ;ignore
- (ls-read stream))
- ((string= feature "lispstrack")
- (ls-read stream))
- (t
- (error "Unknown reader form.")))))))
+ (read-sharp stream))
(t
(let ((string (read-until stream #'terminalp)))
(if (every #'digit-char-p string)
(integer-to-string (+ idx n-required-arguments)) ":" *newline*
(lookup-variable-translation (car arg) new-env)
"="
- (ls-compile (cdr arg) new-env fenv)
+ (ls-compile (cadr arg) new-env fenv)
";" *newline*)
cases)
(incf idx)))
(push (concat "default: break;" *newline*) cases)
- (join (reverse cases) "")))
+ (join (reverse cases))))
"}" *newline*)
"")
;; &rest argument
(define-compilation string-length (x)
(concat "(" (ls-compile x env fenv) ").length"))
+(define-compilation slice (string a &optional b)
+ (concat "(function(){" *newline*
+ "var str = " (ls-compile string env fenv) ";" *newline*
+ "var a = " (ls-compile a env fenv) ";" *newline*
+ "var b;" *newline*
+ (if b
+ (concat "b = " (ls-compile b env fenv) ";" *newline*)
+ "")
+ "return str.slice(a,b);" *newline*
+ "})()"))
+
(define-compilation char (string index)
(concat "("
(ls-compile string env fenv)
(let ((code (ls-compile sexp nil nil)))
(prog1
(concat (join (mapcar (lambda (x) (concat x ";" *newline*))
- *toplevel-compilations*)
- "")
+ *toplevel-compilations*))
code)
(setq *toplevel-compilations* nil))))
projects / jscl.git / blobdiff