• R/O
  • HTTP
  • SSH
  • HTTPS

提交

标签
No Tags

Frequently used words (click to add to your profile)

javac++androidlinuxc#windowsobjective-cqtcocoa誰得pythonphprubygameguibathyscaphec翻訳計画中(planning stage)omegatframeworktwittertestdomvb.netdirectxbtronarduinopreviewerゲームエンジン

A categorical programming language


Commit MetaInfo

修订版26c0818884890fc485063d31725e96f4812642f8 (tree)
时间2021-09-17 06:04:30
作者Corbin <cds@corb...>
CommiterCorbin

Log Message

frame: Allow user-defined functors with parameters.

I waffled over this for a while, but ultimately it's going to be
necessary for expressivity.

更改概述

差异

--- a/frame/frame.ml
+++ b/frame/frame.ml
@@ -13,24 +13,59 @@ let filter =
1313 PrimitiveFilter.empty
1414 (String.split_on_char ' ' primitives)
1515
16+let which_arg s =
17+ let len = String.length s in
18+ if len == 0 || s.[0] != '@' then None
19+ else int_of_string_opt (String.sub s 1 (len - 1))
20+
21+let rec arity_of expr =
22+ match expr with
23+ | Atom a -> Option.fold ~none:0 ~some:(fun x -> x + 1) (which_arg a)
24+ | List l -> List.fold_left max 0 (List.rev_map arity_of l)
25+
26+let is_primitive s =
27+ Option.is_some (which_arg s) || PrimitiveFilter.mem s filter
28+
1629 let cache = ref CodeCache.empty
1730 let basepath = Sys.argv.(1)
1831
32+let rec apply_functor args expr =
33+ match expr with
34+ | Atom a -> Option.fold ~none:expr ~some:(List.nth args) (which_arg a)
35+ | List l -> List (List.hd l :: List.map (apply_functor args) (List.tl l))
36+
1937 let rec replace_code node =
20- match node with
21- | Atom a -> do_atom a
22- | List l -> List (List.hd l :: List.map replace_code (List.tl l))
38+ match node with Atom a -> do_atom a | List l -> do_list l
39+
40+and lookup s =
41+ match CodeCache.find_opt s !cache with
42+ | Some pair -> pair
43+ | None ->
44+ let fullpath = Filename.concat basepath s ^ ".cammy" in
45+ let expr = replace_code (load_sexp fullpath) in
46+ let arity = arity_of expr in
47+ cache := CodeCache.add s (expr, arity) !cache ;
48+ Printf.eprintf "Loaded %s, arity %d\n" s arity ;
49+ (expr, arity)
2350
2451 and do_atom s =
25- if PrimitiveFilter.mem s filter then Atom s
52+ if is_primitive s then Atom s
2653 else
27- match CodeCache.find_opt s !cache with
28- | Some expr -> expr
29- | None ->
30- let fullpath = Filename.concat basepath s ^ ".cammy" in
31- let expr = replace_code (load_sexp fullpath) in
32- cache := CodeCache.add s expr !cache ;
33- expr
54+ let expr, arity = lookup s in
55+ if arity != 0 then failwith ("Functor " ^ s ^ " is not nullary") else expr
56+
57+and do_list l =
58+ let tail = List.map replace_code (List.tl l) in
59+ let head = List.hd l in
60+ match head with
61+ | Atom a ->
62+ if is_primitive a then List (head :: tail)
63+ else
64+ let expr, arity = lookup a in
65+ if arity != List.length tail then
66+ failwith ("Functor " ^ a ^ " misapplied")
67+ else apply_functor tail expr
68+ | List l -> failwith "Functor heads cannot be lists!"
3469
3570 let tree = input_sexp stdin
3671
--- a/stub.scm
+++ b/stub.scm
@@ -61,6 +61,10 @@
6161 (let ((x (car args)))
6262 (if (flonum? x) (cons x (cdr args))
6363 (arg-error x "not a floating-point number"))))
64+(define (arg-list p)
65+ (lambda (args)
66+ (let ((x (car args)))
67+ (cons x (cdr args)))))
6468 (define (arg-pair p1 p2)
6569 (lambda (args1)
6670 (let* ((pair1 (p1 args1)) (x (car pair1)) (args2 (cdr pair1))
@@ -73,6 +77,7 @@
7377 (define ty-parse (match-lambda
7478 ['N arg-nat]
7579 ['F arg-fp]
80+ [('list x) (arg-list (ty-parse x))]
7681 [('pair x y) (arg-pair (ty-parse x) (ty-parse y))]))
7782
7883 (define (cammy-run program ty)