Commit ba829d2d authored by hydraz's avatar hydraz

Feature: methods

parent 9f0efd9a
This diff is collapsed.
......@@ -173,7 +173,7 @@
[else (set! name "")])
(set! counter (+ counter 1))
{ :tag "symbol"
:display-name "temp"
:display-name (.. "temp" name)
:contents (string/format "r_%d%s" counter name) })))
(defmacro for (ctr start end step &body)
......@@ -304,17 +304,6 @@
a lazy version."
(and a b))
(defmacro debug (x)
"Print the value X, then return it unmodified."
(let* [(x-sym (gensym))
(px (pretty x))
(nm (if (>= 20 (len# px))
(.. px " = ")
""))]
`(let* [(,x-sym ,x)]
(print (.. ,nm (pretty ,x-sym)))
,x-sym)))
(defmacro for-pairs (vars tbl &body)
"Iterate over TBL, binding VARS for each key value pair in BODY.
......@@ -341,34 +330,6 @@
(,func-s (next ,tbl-s)))
,tbl nil)))
(defun pretty (value)
"Format VALUE as a valid Lisp expression which can be parsed."
(with (ty (type# value))
(cond
[(= ty "table")
(with (tag (get-idx value :tag))
(cond
[(= tag "list")
(with (out '())
(for i 1 (n value) 1
(set-idx! out i (pretty (get-idx value i))))
(.. "(" (concat out " ") ")"))]
[(and (= (type# (getmetatable value)) "table")
(= (type# (get-idx (getmetatable value) :--pretty-print)) "function"))
((get-idx (getmetatable value) :--pretty-print) value)]
[(= tag "list") (get-idx value :contents)]
[(= tag "symbol") (get-idx value :contents)]
[(= tag "key") (.. ":" (get-idx value :value))]
[(= tag "string") (string/format "%q" (get-idx value :value))]
[(= tag "number") (tostring (get-idx value :value))]
[else
(let* [(out '())]
(for-pairs (k v) value
(set! out (cons (.. (pretty k) " " (pretty v)) out)))
(.. "{" (.. (concat out " ") "}")))]
[else (tostring value)]))]
[(= ty "string") (string/format "%q" value)]
[else (tostring value)])))
(define arg
"The arguments passed to the currently executing program"
......
(import base (defmacro if ! when car and or
cdr and pretty print debug /=
% get-idx defun = n >= error
progn gensym for list + else))
(import base (defmacro if ! when car and or cdr and print /= % get-idx defun = n
>= error progn gensym for list + else))
(import base)
(import type (list? empty?))
(import list (cars cadrs caar cadar map cadr
cdar cddr caddar snoc push-cdr!
(import type (list? empty? pretty))
(import list (cars cadrs caar cadar map cadr cdar cddr caddar snoc push-cdr!
nth))
(import lua/basic (getmetatable ..))
......
......@@ -2,11 +2,11 @@
get-idx gensym =))
(import binders (let))
(import list (for-each push-cdr! any map traverse reduce))
(import type (symbol? list? function? table?))
(import type (symbol? list? function? table? pretty))
(import table (.> getmetatable))
(import lua/os (clock))
(import base (print pretty))
(import base (print))
(defun slot? (symb)
"Test whether SYMB is a slot. For this, it must be a symbol, whose
......
......@@ -72,15 +72,11 @@
(import lua/basic (setmetatable .. n))
(import function (compose invokable?))
(import binders (let* letrec))
(import base (defun defmacro and
get-idx set-idx! =
if error for pretty
for-pairs gensym >
or + <))
(import list (reduce map filter prune
car cdr cadr cons nth
push-cdr! reverse maybe-map))
(import type (list? function? eq? eql?))
(import base (defun defmacro and get-idx set-idx! = if error for for-pairs
gensym > or + <))
(import list (reduce map filter prune car cdr cadr cons nth push-cdr! reverse
maybe-map))
(import type (list? function? eq? eql? pretty))
(defun lens (view over)
"Define a lens using VIEW and OVER as the getter and the replacer
......
......@@ -20,16 +20,13 @@
in proportion to the size of the input list. This is generally a bad
thing."
(import base (defun defmacro when unless let* set-idx!
get-idx for gensym -or slice /= % else
pretty print error tostring -and
unpack debug if n + - >= > = ! with
apply and progn .. * while <= < or
values-list first second))
(import base (defun defmacro when unless let* set-idx! get-idx for gensym -or
slice /= % else print error tostring -and unpack if n + - >= > =
! with apply and progn .. * while <= < or values-list first
second))
(import base)
(import lua/table)
(import type (nil? list? empty? assert-type! exists? falsey? eq? neq? type))
(import type (nil? list? empty? assert-type! exists? falsey? eq? neq? type pretty))
(import lua/math (min max huge))
(defun car (x)
......
......@@ -158,16 +158,12 @@
(import lua/basic (xpcall))
(import lua/math (max))
(import base ( defun defmacro if get-idx
and gensym error for set-idx!
quasiquote list or pretty
slice concat debug apply
/= n = ! - + / * >= <= % .. else ))
(import base (defun defmacro if get-idx and gensym error for set-idx!
quasiquote list or slice concat apply /= n = ! - + / * >= <= % ..
else))
(import type ())
(import list ( car caddr cadr cdr append for-each
map filter push-cdr! range snoc
nth last elem? ))
(import list (car caddr cadr cdr append for-each map filter push-cdr! range snoc
nth last elem?))
(import string (char-at sub))
(import binders (let*))
......
(import base (lambda defun defmacro progn for while if quasiquote const-val and
or xpcall pretty pcall values-list gensym tostring tonumber
or xpcall pcall values-list gensym tostring tonumber
require => <=> unpack list when unless arg apply for-pairs first
second third fourth fifth sixth seventh ninth tenth + - * / % ^ !
.. n debug else) :export)
.. n else) :export)
(import base)
(import string (format concat $) :export)
(import binders () :export)
......
(import base (defun getmetatable if n progn with for tostring len#
type# >= > < <= = /= + - car or and list when set-idx!
get-idx getmetatable while .. pretty defmacro debug else))
get-idx getmetatable while .. defmacro else))
(import type (pretty))
(import base (concat) :export)
(import list)
(import binders (loop let*))
......
(import base (defmacro defun let* when if list unless debug gensym slice
progn get-idx set-idx! error = /= % - + n or for for-pairs
with ! apply else))
(import base (defmacro defun let* when if list unless gensym slice progn get-idx
set-idx! error = /= % - + n or for for-pairs with ! apply else))
(import lua/string (sub))
(import lua/basic (getmetatable setmetatable next len#) :export)
(import type (empty? list? eq? key?))
......
This diff is collapsed.
......@@ -13,10 +13,11 @@
(setmetatable
{ :tag "continuation"
:thread coroutine }
{ :--pretty-print (const "«continuation»")
:__call (lambda (k &args)
{ :__call (lambda (k &args)
(apply continue (.> k :thread) args)) }))
(defmethod (pretty continuation) (x) "«continuation»")
(defun call-with-prompt (prompt-tag body handler)
"Call the thunk BODY with a prompt PROMPT-TAG in scope. If BODY
aborts to PROMPT-TAG, then HANDLER is invoked with the coroutine
......@@ -122,6 +123,10 @@
"Abort to the prompt TAG, giving REST as arguments to the handler."
(c/yield (cons :abort tag rest)))
(defun abort/p (tag &rest)
"Abort to the prompt TAG, giving REST as arguments to the handler."
(c/yield (cons :abort tag rest)))
(defmacro reset (&body)
"Establish a prompt, and evaluate BODY within that prompt.
......
(defmacro defgeneric (name ll &attrs)
"Define a generic method called NAME with the arguments given in LL,
and the attributes given in ATTRS. Note that documentation _must_
come after LL; The mixed syntax accepted by `define` is not allowed.
### Examples:
```cl :no-test
> (defgeneric my-pretty-print (x)
. \"Pretty-print a value.\")
out = «method: (my-pretty-print x)»
> (defmethod (my-pretty-print string) (x) x)
out = nil
> (my-pretty-print \"foo\")
out = \"foo\"
```"
(let* [(this (gensym 'this))
(method (gensym 'method))]
`(define ,name
,@attrs
(setmetatable
{ :lookup {} }
{ :__call (lambda ,(cons this ll)
(let* [(,method (.> ,this :lookup ,@(map (cut list `type <>) ll)))]
(unless ,method
(error! (.. "No matching method to call for "
,@(flat-map (lambda (x)
`((type ,x) " "))
ll)
"\nthere are methods to call for "
(pretty (keys (.> ,this :lookup))))))
(,method ,@ll)))
:--pretty-print (lambda (,this)
,(.. "«method: (" (symbol->string name) " "
(concat (map symbol->string ll) " ") ")»")) }))))
(defun put! (t typs l) :hidden
"Insert the method L (at TYPS) into the lookup table T, creating any needed
definitions."
(case typs
[(?x) (.<! t x l)]
[(?x . ?y)
(if (.> t x)
(put! (.> t x) y l)
(progn
(.<! t x {})
(put! (.> t x) y l)))]))
(defmacro defmethod (name ll &body)
"Add a case to the generic method NAME with the arguments LL and the body
BODY. The types of arguments for this specialisation are given in the list
NAME, and the argument names are merely used to build the lambda.
BODY has in scope a symbol, `myself`, that refers specifically to this
instantiation of the generic method NAME. For instance, in
```cl :no-test
(defmethod (my-pretty-print string) (x)
(myself (.. \"foo \" x)))
```
`myself` refers only to the case of `my-pretty-print` that handles strings.
### Example
```cl :no-test
> (defgeneric my-pretty-print (x)
. \"Pretty-print a value.\")
out = «method: (my-pretty-print x)»
> (defmethod (my-pretty-print string) (x) x)
out = nil
> (my-pretty-print \"foo\")
out = \"foo\"
```"
`(put! ,(car name) (list :lookup ,@(map symbol->string (cdr name)))
(letrec [(,'self (lambda ,ll ,@body))]
,'self)))
......@@ -16,11 +16,9 @@
out = «hash-set: »
```"
(let* [(hash (or hash-function id))]
(setmetatable
{ :tag "set"
:hash hash
:data {} }
*set-metatable*)))
{ :tag "set"
:hash hash
:data {} }))
(define *set-metatable* :hidden
{ :--pretty-print (lambda (x)
......@@ -34,6 +32,18 @@
(.> y :hash))
same-data))) })
(defmethod (eq? set set) (x y)
(let* [(same-data true)]
(for-pairs (k _) (.> y :data)
(when (= (.> x :data k) nil)
(set! same-data false)))
(and (= (.> x :hash)
(.> y :hash))
same-data)))
(defmethod (pretty set) (x)
(.. "«hash-set: " (concat (map pretty (set->list x)) " ") "»"))
(defun set? (x)
"Check that X is a set.
......
......@@ -442,7 +442,13 @@
(set! run false)]
[(= (co/status exec) "dead")
(let* [(lvl (state/get! (last state)))]
(print! (.. "out = " (colored 96 (pretty lvl))))
(with (pretty-fun pretty)
(when-with (pretty-var (scope/get scope "pretty"))
(with (pretty-val (state/get! (.> compiler :states pretty-var)))
(set! pretty-fun pretty-val)))
(print! (.. "out = " (colored 96 (pretty-fun lvl)))))
(.<! global (lua/push-escape-var! (scope/add! scope "out" "defined" lvl)
compileState)
lvl))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment